mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-18 07:12:26 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'cmpc-refactor-next' into 'develop'

Browse source 
Futher refactor of the compiler

See merge request embeddable-common-lisp/ecl!313
This commit is contained in:
Marius Gerbershagen 2023-12-28 13:31:03 +00:00
commit e0cd45299d
22 changed files with 887 additions and 840 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -0,0 +1,205 @@
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya
;;;; Copyright (c) 1990, Giuseppe Attardi
;;;; Copyright (c) 2023, Daniel Kochmański
;;;;
;;;; See the file 'LICENSE' for the copyright details.
;;;;
;;;; 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).
(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)))
(defun open-inline-block ()
(wt-nl-open-brace)
(incf *inline-blocks*))
(defun close-inline-blocks ()
(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)
;; 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.
;;
;; ARGS-TO-BE-SAVED is a positional list created by C-INLINE, instructing that
;; the value should be saved in a temporary variable.
;;
;; 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 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 i from 0
for rep-type = (lisp-type->rep-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)))))
(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))))
(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))))
(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))))
(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)
(let ((args (c1form-arg 0 form)))
(loop with *destination* = 'TRASH
while (rest args)
do (c2expr* (pop args)))
(emit-inline-form (first args) forms)))
(defun emit-inlined-values (form 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))
(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))))
(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))))))
;;;
;;; inline-args:
;;; returns a list of pairs (type loc)
;;; side effects: emits code for temporary variables
;;;
;;; Whoever calls this function must wrap the body in WITH-INLINE-BLOCKS.
;;;
(defun inline-args (forms)
(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))

68
src/cmp/cmpbackend-cxx/cmpc-inliner.lsp → src/cmp/cmpbackend-cxx/cmpc-fun-inl.lsp
View file

@ -2,8 +2,9 @@
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya
;;;; Copyright (c) 1990, Giuseppe Attardi
;;;; Copyright (c) 2023, Daniel Kochmański
;;;;
;;;; See the file 'LICENSE' for the copyright details.
;;;;
@ -27,27 +28,17 @@
one-liner ;;; Whether the expansion spans more than one line
)
(defun inlined-arg-loc (arg)
(second arg))
(defun inlined-arg-type (arg)
(first arg))
(defun inlined-arg-rep-type (arg)
(loc-representation-type (second arg)))
(defmacro define-c-inliner (fname lambda-list &body body)
`(setf (gethash ',fname *cinline-dispatch-table*)
#'(lambda ,lambda-list (block nil ,@body))))
(defun apply-inliner (fname return-type inlined-args)
(let ((fd (gethash fname *cinline-dispatch-table*)))
(if fd
(apply fd return-type inlined-args)
(default-c-inliner fname return-type inlined-args))))
(ext:if-let ((fd (gethash fname *cinline-dispatch-table*)))
(apply fd return-type inlined-args)
(default-c-inliner fname return-type inlined-args)))
(defun default-c-inliner (fname return-type inlined-args)
(let* ((arg-types (mapcar #'first inlined-args))
(let* ((arg-types (mapcar #'inlined-arg-type inlined-args))
(ii (inline-function fname arg-types return-type)))
(and ii (apply-inline-info ii inlined-args))))
@ -249,33 +240,18 @@
(wt "cl_env_copy->nvalues = " (length output-vars) ";")
'VALUEZ))))))
(defun coerce-locs (inlined-args &optional types args-to-be-saved)
;; INLINED-ARGS is a list of (TYPE LOCATION) produced by the
;; inline code. ARGS-TO-BE-SAVED is a positional list created by
;; C-INLINE, instructing that the value should be saved in a temporary
;; variable. Finally, TYPES is a list of destination types, to which
;; the former values are coerced. The destination types can be
;; - A lisp type (:OBJECT, :FINXUM, etc)
;; - A machine representation type (T, INTEGER, etc)
(loop with block-opened = nil
for (lisp-type loc) in inlined-args
for type in (or types '#1=(:object . #1#))
for i from 0
for rep-type = (lisp-type->rep-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 (loc-representation-type loc))
loc)
(t
`(COERCE-LOC ,rep-type ,loc)))))
;;; 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)))
(apply #'produce-inline-loc
(list inlined-arg)
(if (eq (loc-representation-type dest-loc) :bool)
(case rep-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
(: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*)))))))

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

@ -28,6 +28,24 @@
;;; compilation mode, respectively.
;;;
;;; Valid property names for open coded functions are:
;;; :INLINE-ALWAYS
;;; :INLINE-UNSAFE non-safe-compile only
;;;
;;; Each property is a list of 'inline-info's, where each inline-info is:
;;; ( types { type | boolean } { string | function } ).
;;;
;;; For each open-codable function, open coding will occur only if there exits
;;; an appropriate property with the argument types equal to 'types' and with
;;; the return-type equal to 'type'.
;;;
;;; The third element is T if and only if side effects may occur by the call of
;;; the function. Even if *DESTINATION* is TRASH, open code for such a function
;;; with side effects must be included in the compiled code.
;;;
;;; The forth element is T if and only if the result value is a new Lisp object,
;;; i.e., it must be explicitly protected against GBC.
(defun inline-information (name safety)
(gethash (list name safety) *inline-information*))

178
src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp
View file

@ -1,178 +0,0 @@
;;;; -*- 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
;;;;
;;;; See the file 'LICENSE' for the copyright details.
;;;;
;;;; Open coding optimizer.
(in-package "COMPILER")
;;; Valid property names for open coded functions are:
;;; :INLINE-ALWAYS
;;; :INLINE-UNSAFE non-safe-compile only
;;;
;;; Each property is a list of 'inline-info's, where each inline-info is:
;;; ( types { type | boolean } { string | function } ).
;;;
;;; For each open-codable function, open coding will occur only if there exits
;;; an appropriate property with the argument types equal to 'types' and with
;;; the return-type equal to 'type'.
;;;
;;; The third element is T if and only if side effects may occur by the call of
;;; the function. Even if *DESTINATION* is TRASH, open code for such a function
;;; with side effects must be included in the compiled code.
;;;
;;; The forth element is T if and only if the result value is a new Lisp object,
;;; i.e., it must be explicitly protected against GBC.
(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)
(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))))
(defun save-inline-loc (loc)
(let* ((rep-type (loc-representation-type (second loc)))
(temp (make-inline-temp-var (first loc) rep-type)))
(set-loc temp loc)
temp))
(defun emit-inlined-variable (form rest-forms)
(let ((var (c1form-arg 0 form))
(value-type (c1form-primary-type form)))
(if (var-changed-in-form-list var rest-forms)
(let ((temp (make-inline-temp-var value-type (var-rep-type var))))
(set-loc temp var)
(list value-type temp))
(list value-type var))))
(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)
(list (c1form-primary-type form1) (c1form-arg 0 form1))
(emit-inlined-variable (make-c1form 'VARIABLE form vref nil) rest-forms))))
(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)
(list type temp)))
(defun emit-inlined-progn (form forms)
(let ((args (c1form-arg 0 form)))
(loop with *destination* = 'TRASH
while (rest args)
do (c2expr* (pop args)))
(emit-inline-form (first args) forms)))
(defun emit-inlined-values (form 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))
(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)
(list type temp))
(list type
(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))))))
(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)
(list type temp))
(list type
(list 'si:instance-ref
(first (coerce-locs
(inline-args (list (c1form-arg 0 form)))))
(c1form-arg 1 form)
#+nil (c1form-arg 2 form))))))
(defun emit-inline-form (form forms)
(with-c1form-env (form form)
(case (c1form-name form)
(LOCATION
(list (c1form-primary-type form) (c1form-arg 0 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))
#+clos
(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)))
(let ((*destination* temp)) (c2expr* form))
(list type temp))))))
;;;
;;; inline-args:
;;; returns a list of pairs (type loc)
;;; side effects: emits code for temporary variables
;;;
;;; Whoever calls inline-args must bind *inline-blocks* to 0 and afterwards
;;; call close-inline-blocks
;;;
(defun inline-args (forms)
(loop for form-list on forms
for form = (first form-list)
collect (emit-inline-form form (rest form-list))))
(defun destination-type ()
(rep-type->lisp-type (loc-representation-type *destination*))
;;(loc-type *destination*)
)
(defun maybe-open-inline-block ()
(unless (plusp *inline-blocks*)
(open-inline-block)))
(defun open-inline-block ()
(wt-nl-open-brace)
(incf *inline-blocks*))
(defun close-inline-blocks ()
(loop for i of-type fixnum from 0 below *inline-blocks*
do (wt-nl-close-brace)))

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

@ -93,48 +93,44 @@
(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 0)))
(setf arg1 (pop arguments))
(when (null arguments)
(return (inlined-arg-loc arg1)))
(loop for arg2 = (pop arguments)
for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+)
do (if arguments
(setf arg1 (save-inline-loc result))
(return result))))
(define-c-inliner - (return-type arg1 &rest arguments &aux arg2)
(when (null arguments)
(return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)")))
(loop for arg2 = (pop arguments)
for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-)
do (if arguments
(setf arg1 (save-inline-loc result))
(return result))))
(define-c-inliner * (return-type &rest arguments &aux arg1 arg2)
(when (null arguments)
(return (make-vv :rep-type :fixnum :value 1)))
(setf arg1 (pop arguments))
(when (null arguments)
(return (inlined-arg-loc arg1)))
(loop for arg2 = (pop arguments)
for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*)
do (if arguments
(setf arg1 (save-inline-loc result))
(return result))))
(setf arg2 (pop arguments))
(when (null arguments)
(return (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*)))
(cmperr "The C inliner for (FUNCTION *) expected at most 2 arguments."))
(define-c-inliner + (return-type &rest arguments &aux arg1 arg2)
(when (null arguments)
(return (make-vv :rep-type :fixnum :value 0)))
(setf arg1 (pop arguments))
(when (null arguments)
(return (inlined-arg-loc arg1)))
(setf arg2 (pop arguments))
(when (null arguments)
(return (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+)))
(cmperr "The C inliner for (FUNCTION +) expected at most 2 arguments."))
(define-c-inliner - (return-type arg1 &rest arguments &aux arg2)
(when (null arguments)
(return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)")))
(setf arg2 (pop arguments))
(when (null arguments)
(return (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-)))
(cmperr "The C inliner for (FUNCTION -) expected at most 2 arguments."))
(define-c-inliner / (return-type arg1 &rest arguments &aux arg2)
(when (null arguments)
(return (inline-arith-unop return-type arg1
"ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)")))
(loop for arg2 = (pop arguments)
for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/)
do (if arguments
(setf arg1 (save-inline-loc result))
(return result))))
(setf arg2 (pop arguments))
(when (null arguments)
(return (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/)))
(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)))

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

@ -56,6 +56,29 @@
(defvar *exit*)
(defvar *unwind-exit*)
;;; Destination of output of different forms.
;;;
;;; Valid *DESTINATION* locations are:
;;;
;;; var-object Variable
;;; loc-object VV Location
;;; TRASH Value may be thrown away.
;;; LEAVE Object returned from current function.
;;; VALUEZ Values vector.
;;; VALUE0
;;; ( VALUE i ) Nth value
;;; ( BIND var alternative ) Alternative is optional
;;; ( JUMP-TRUE label )
;;; ( JUMP-FALSE label )
(defvar *destination*)
(defun tmp-destination (loc)
(case loc
(VALUEZ 'VALUEZ)
(TRASH 'TRASH)
(T 'LEAVE)))
;;; C forms to find out (SETF fname) locations
(defvar *setf-definitions*) ; holds { name fun-vv name-vv }*
(defvar *global-cfuns-array*) ; holds { fun-vv fname-loc fun }*
@ -85,13 +108,9 @@
;;;
(defmacro with-cxx-env (() &body body)
`(let ((*inline-blocks* 0)
(*open-c-braces* 0)
(*temp* 0)
(*max-temp* 0)
`(let ((*opened-c-braces* 0)
(*inline-blocks* 0)
(*next-cfun* 0)
(*last-label* 0)
(*unwind-exit* nil)
(*inline-information*
(ext:if-let ((r (machine-inline-information *machine*)))
(si:copy-hash-table r)
@ -105,6 +124,29 @@
(*compiler-declared-globals* (make-hash-table)))
,@body))
;;; Block IR creation environment.
;;; FIXME Still mixed with CXX bits. Clean this up while separating the backend.
(defmacro with-bir-env ((&key env level volatile) &body body)
`(let* ((*lcl* 0)
(*temp* 0)
(*max-temp* 0)
(*lex* 0)
(*max-lex* 0)
(*env-lvl* 0)
(*env* ,env)
(*max-env* *env*)
(*level* ,level)
(*last-label* 0)
(*volatile* ,volatile)
;;
(*ihs-used-p* nil)
(*aux-closure* nil)
;;
(*exit* 'LEAVE)
(*unwind-exit* '(LEAVE))
(*destination* *exit*))
,@body))
(defun-cached env-var-name (n) eql
(format nil "env~D" n))
@ -147,11 +189,19 @@
(let ((code (incf *next-cfun*)))
(format nil prefix code (lisp-to-c-name lisp-name))))
(defmacro with-lexical-scope (() &body body)
`(progn
(wt-nl-open-brace)
;;; The macro WITH-INLINE-BLOCKS is used by callers who may optionally need to
;;; introduce inner lexical scope to create variables. Most notably it is used
;;; for temporary variables that are bound to local evaluation results.
(defmacro with-inline-blocks (() &body body)
`(let ((*inline-blocks* 0)
(*temp* *temp*))
,@body
(wt-nl-close-brace)))
(close-inline-blocks)))
(defmacro with-lexical-scope (() &body body)
`(with-inline-blocks ()
(open-inline-block)
,@body))
;;; *LAST-LABEL* holds the label# of the last used label. This is used by the

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

@ -9,22 +9,6 @@
(in-package #:compiler)
;;; Functions that use MAYBE-SAVE-VALUE should rebind *TEMP*.
(defun maybe-save-value (value &optional (other-forms nil other-forms-flag))
(declare (si::c-local))
(let ((name (c1form-name value)))
(cond ((eq name 'LOCATION)
(c1form-arg 0 value))
((and (eq name 'VARIABLE)
other-forms-flag
(not (var-changed-in-form-list (c1form-arg 0 value) other-forms)))
(c1form-arg 0 value))
(t
(let* ((temp (make-temp-var))
(*destination* temp))
(c2expr* value)
temp)))))
;;; FIXME functions declared as SI::C-LOCAL can't be called from the stack
;;; because they are not installed in the environment. That means that if we
;;; have such function and call it with too many arguments it will be
@ -33,37 +17,82 @@
;;;
;;; c2fcall:
;;;
;;; FUN the function to be called
;;; ARGS is the list of arguments
;;; FUN: the function to be called
;;; ARGS: the list of arguments
;;; FUN-VAL depends on the particular call type
;;; CALL-TYPE is (member :LOCAL :GLOBAL :UKNOWN)
;;; :LOCAL structure FUN [see cmprefs.lsp]
;;; :GLOBAL function name [symbol or (SETF symbol)]
;;; :UNKNOWN the value NIL
;;; CALL-TYPE: (member :LOCAL :GLOBAL :UKNOWN)
;;;
(defun c2fcall (c1form fun args fun-val call-type)
(if (> (length args) si:c-arguments-limit)
(c2call-stack c1form fun args nil)
(ecase call-type
(:local (c2call-local c1form fun-val args))
(:global (c2call-global c1form fun-val args))
(:unknown (c2call-unknown c1form fun args)))))
(with-inline-blocks ()
(ecase call-type
(:local (c2call-local c1form fun-val args))
(:global (c2call-global c1form fun-val args))
(:unknown (c2call-unknown c1form fun args))))))
(defun c2mcall (c1form form args fun-val call-type)
(declare (ignore fun-val call-type))
(c2call-stack c1form form args t))
;;;
;;; c2call-stack:
;;;
;;; This is the most generic way of calling functions. First we push them on
;;; the stack, and then we apply from the stack frame. Other variants call
;;; inline-args and put results directly in the function call.
;;;
(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 ((*destination* (if values-p 'VALUEZ 'LEAVE)))
(dolist (arg args)
(c2expr* arg)
(if values-p
(wt-nl "ecl_stack_frame_push_values(" frame ");")
(wt-nl "ecl_stack_frame_push(" frame ",value0);"))))
(unwind-exit (call-stack-loc nil loc)))))
;;;
;;; c2call-global:
;;;
;;; ARGS is the list of arguments
;;; LOC is either NIL or the location of the function object
;;; LOC: the location of the function object or NIL
;;; ARGS: the list of arguments
;;;
(defun c2call-global (c1form fname args)
(let ((fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p)))
(when (and fun (c2try-tail-recursive-call fun args))
(return-from c2call-global))
(let* ((*inline-blocks* 0)
(*temp* *temp*))
(unwind-exit (call-global-loc fname fun args (c1form-primary-type c1form)
(loc-type *destination*)))
(close-inline-blocks))))
(unwind-exit (call-global-loc fname fun
(inline-args args)
(type-and (c1form-primary-type c1form)
(loc-type *destination*))))))
;;;
;;; c2call-local:
;;;
;;; FUN: the function object
;;; ARGS: the list of arguments
;;;
(defun c2call-local (c1form fun args)
(declare (type fun fun))
(unless (c2try-tail-recursive-call fun args)
(unwind-exit (call-loc (fun-name fun) fun
(inline-args args)
(c1form-primary-type c1form)))))
(defun c2call-unknown (c1form form args)
(declare (ignore c1form))
(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)))
(args (inline-args args)))
(unwind-exit (call-unknown-global-loc loc args function-p))))
;;; Tail-recursion optimization for a function F is possible only if
;;; 1. F receives only required parameters, and
@ -89,13 +118,10 @@
((or (consp ue) (labelp ue) (eq ue 'IHS-ENV)))
(t (baboon :format-control "tail-recursion-possible: unexpected situation.")))))
(defun last-call-p ()
(eq *exit* 'LEAVE))
(defun c2try-tail-recursive-call (fun args)
(when (and *tail-recursion-info*
(eq fun (first *tail-recursion-info*))
(last-call-p)
(eq *exit* 'LEAVE)
(tail-recursion-possible)
(inline-possible (fun-name fun))
(= (length args) (length (rest *tail-recursion-info*))))
@ -107,88 +133,71 @@
(cmpdebug "Tail-recursive call of ~s was replaced by iteration." (fun-name fun))
t))
(defun c2call-local (c1form fun args)
(declare (type fun fun))
(unless (c2try-tail-recursive-call fun args)
(let ((*inline-blocks* 0)
(*temp* *temp*))
(unwind-exit (call-loc (fun-name fun) fun (inline-args args)
(c1form-primary-type c1form)))
(close-inline-blocks))))
(defun c2call-unknown (c1form form args)
(declare (ignore c1form))
(let* ((*inline-blocks* 0)
(*temp* *temp*)
(form-type (c1form-primary-type form))
(function-p (and (subtypep form-type 'function)
(policy-assume-right-type)))
(loc (maybe-save-value form args)))
(unwind-exit (call-unknown-global-loc loc (inline-args args) function-p))
(close-inline-blocks)))
(defun c2call-stack (c1form form args values-p)
(declare (ignore c1form))
(let* ((*temp* *temp*)
(loc (maybe-save-value form args)))
(with-stack-frame (frame)
(let ((*destination* (if values-p 'VALUEZ 'LEAVE)))
(dolist (arg args)
(c2expr* arg)
(if values-p
(wt-nl "ecl_stack_frame_push_values(" frame ");")
(wt-nl "ecl_stack_frame_push(" frame ",value0);"))))
(unwind-exit (call-stack-loc nil loc)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; CALL LOCATIONS
;;;
;;;
;;; call-stack-loc
;;;
;;; FNAME: the name of the function or NIL
;;; LOC: the location containing function
;;;
(defun call-stack-loc (fname loc)
`(CALL-STACK ,loc ,fname))
;;;
;;; call-loc
;;;
;;; FNAME: the name of the function
;;; FUN: a function object
;;; ARGS: a list of INLINED-ARGs
;;; TYPE: the type to which the output is coerced
;;;
(defun call-loc (fname fun args type)
(declare (ignore fname))
`(CALL-NORMAL ,fun ,(coerce-locs args) ,type))
;;;
;;; call-global:
;;; FNAME: the name of the function
;;; LOC: either a function object or NIL
;;; FUN: either a function object or NIL
;;; ARGS: a list of typed locs with arguments
;;; RETURN-TYPE: the type to which the output is coerced
;;; TYPE: the type to which the output is coerced
;;;
(defun call-global-loc (fname fun args return-type expected-type)
;; Check whether it is a global function that we cannot call directly.
(when (and (or (null fun) (fun-global fun)) (not (inline-possible fname)))
(return-from call-global-loc
(call-unknown-global-fun fname (inline-args args))))
(defun call-global-loc (fname fun args type)
(setf args (inline-args args))
;; Check whether it is a global function that we cannot call directly.
(when (not (inline-possible fname))
(return-from call-global-loc
(call-unknown-global-fun fname args)))
;; Try with a function that has a C-INLINE expansion
(let ((inline-loc (apply-inliner fname
(type-and return-type expected-type)
args)))
(when inline-loc
(return-from call-global-loc inline-loc)))
(ext:when-let ((inline-loc (apply-inliner fname type args)))
(return-from call-global-loc inline-loc))
;; Call to a function defined in the same file. Direct calls are
;; only emitted for low or neutral values of DEBUG is >= 2.
(when (and (policy-use-direct-C-call)
(or (fun-p fun)
(and (null fun)
(setf fun (find fname *global-funs* :test #'same-fname-p
:key #'fun-name)))))
(return-from call-global-loc (call-loc fname fun args return-type)))
;; Call to a function defined in the same file. Direct calls are only emitted
;; for low or neutral values of DEBUG, that is DEBUG < 2.
(when (and fun (policy-use-direct-C-call))
(return-from call-global-loc
(call-loc fname fun args type)))
;; Call to a global (SETF ...) function
(when (not (symbolp fname))
(return-from call-global-loc
(call-unknown-global-fun fname args)))
;; Call to a function whose C language function name is known,
;; either because it has been proclaimed so, or because it belongs
;; to the runtime.
;; Call to a function whose C language function name is known because it
;; belongs to the runtime.
(multiple-value-bind (found fd minarg maxarg)
(si:mangle-name fname t)
(when found
(return-from call-global-loc
(call-exported-function-loc fname args fd minarg maxarg t return-type))))
(call-exported-function-loc fname args fd minarg maxarg t type))))
;; Call to a function whose C language function name is known because it has
;; been proclaimed so.
(when (policy-use-direct-C-call)
(ext:when-let ((fd (si:get-sysprop fname 'Lfun)))
(multiple-value-bind (minarg maxarg found) (get-proclaimed-narg fname)
@ -202,20 +211,16 @@
(multiple-value-setq (found ignored minarg maxarg)
(si:mangle-name fname)))
(unless found
(cmperr "Can not call the function ~A using its exported C name ~A because its function type has not been proclaimed."
(cmperr "Can not call the function ~A using its exported C name ~A ~
because its function type has not been proclaimed."
fname fd)))
(return-from call-global-loc
(call-exported-function-loc fname args fd minarg maxarg
(si:mangle-name fname) return-type)))))
(si:mangle-name fname) type)))))
(call-unknown-global-fun fname args))
(defun call-loc (fname fun args type)
(declare (ignore fname))
`(CALL-NORMAL ,fun ,(coerce-locs args) ,type))
(defun call-exported-function-loc (fname args fun-c-name minarg maxarg in-core
return-type)
(defun call-exported-function-loc (fname args fun-c-name minarg maxarg in-core type)
(unless in-core
;; We only write declarations for functions which are not in lisp_external.h
(multiple-value-bind (val declared)
@ -237,20 +242,23 @@
(setf (gethash fun-c-name *compiler-declared-globals*) 1))))
(let ((fun (make-fun :name fname :global t :cfun fun-c-name :lambda 'NIL
:minarg minarg :maxarg maxarg)))
(call-loc fname fun args return-type)))
(call-loc fname fun args type)))
;;;
;;; call-unknown-global-loc
;;; LOC is NIL or location containing function
;;; ARGS is the list of typed locations for arguments
;;;
(defun call-unknown-global-loc (loc args &optional function-p)
;;; LOC: the location containing the function or NIL
;;; ARGS: a list of INLINED-ARGs
;;; 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-unknown-global-fun
;;; FNAME is the name of the global function
;;; ARGS is the list of typed locations for arguments
;;;
;;; FNAME: the name of the global function
;;; ARGS: a list of INLINED-ARGs
;;;
(defun call-unknown-global-fun (fname args)
`(CALL-INDIRECT (FDEFINITION ,fname) ,(coerce-locs args) ,fname t))
@ -260,11 +268,3 @@
;;; 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-stack-loc
;;; LOC is NIL or location containing function
;;; ARGS is the list of typed locations for arguments
;;;
(defun call-stack-loc (fname loc)
`(CALL-STACK ,loc ,fname))

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

@ -45,8 +45,7 @@
(progn
(let ((*destination* 'VALUEZ))
(c2expr* val))
(let ((name (get-object (blk-name blk))))
(wt-nl "cl_return_from(" (blk-var blk) "," name ");")))
(unwind-flee blk :return-from))
(let ((*destination* (blk-destination blk))
(*exit* (blk-exit blk)))
(c2expr val))))
@ -55,39 +54,39 @@
(defun c2tagbody (c1form tag-loc body)
(declare (type var tag-loc)
(ignore c1form))
(if (null (var-kind tag-loc))
;; only local goto's
(dolist (x body (c2tagbody-body body))
;; Allocate labels.
(when (and (tag-p x) (plusp (tag-ref x)))
(setf (tag-jump x) (next-label t))))
;; some tag used non locally or inside an unwind-protect
(let ((*env* *env*) (*env-lvl* *env-lvl*)
(*lex* *lex*) (*lcl* *lcl*)
(*inline-blocks* 0)
(env-grows (env-grows (var-ref-ccb tag-loc))))
(when env-grows
(let ((env-lvl *env-lvl*))
(macrolet ((do-tags ((tag forms result) &body body)
;; Allocate labels.
`(dolist (,tag ,forms ,result)
(when (and (tag-p ,tag) (plusp (tag-ref ,tag)))
(setf (tag-jump ,tag) (next-label t))
,@body))))
(if (null (var-kind tag-loc))
;; only local goto's
(do-tags (tag body (c2tagbody-body body)))
;; some tag used non locally or inside an unwind-protect
(let ((*env* *env*) (*env-lvl* *env-lvl*)
(*lex* *lex*) (*lcl* *lcl*)
(*inline-blocks* 0)
(env-grows (env-grows (var-ref-ccb tag-loc))))
(when env-grows
(let ((env-lvl *env-lvl*))
(maybe-open-inline-block)
(wt-nl "volatile cl_object env" (incf *env-lvl*)
" = env" env-lvl ";")))
(when (eq :OBJECT (var-kind tag-loc))
(setf (var-loc tag-loc) (next-lcl))
(maybe-open-inline-block)
(wt-nl "volatile cl_object env" (incf *env-lvl*)
" = env" env-lvl ";")))
(when (eq :OBJECT (var-kind tag-loc))
(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)
(with-unwind-frame (tag-loc)
(progn
;; Allocate labels.
(dolist (tag body)
(when (and (tag-p tag) (plusp (tag-ref tag)))
(setf (tag-jump tag) (next-label nil))
(wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))")
(wt-go (tag-jump tag))))
(when (var-ref-ccb tag-loc)
(wt-nl "ecl_internal_error(\"GO found an inexistent tag\");")))
(c2tagbody-body body))
(close-inline-blocks))))
(wt-nl "cl_object " tag-loc ";"))
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc)
(with-unwind-frame (tag-loc)
(progn
(do-tags (tag body nil)
(unwind-cond (tag-jump tag) :jump-eq
'VALUEZ (tag-index tag)))
(when (var-ref-ccb tag-loc)
(wt-nl "ecl_internal_error(\"GO found an inexistent tag\");")))
(c2tagbody-body body))
(close-inline-blocks)))))
(defun c2tagbody-body (body)
;;; INV: BODY is a list of tags and forms. We have processed the body
@ -105,20 +104,22 @@
(defun c2go (c1form tag nonlocal)
(declare (ignore c1form))
(if nonlocal
(wt-nl "cl_go(" (tag-var tag) ",ecl_make_fixnum(" (tag-index tag) "));")
(unwind-flee tag :go)
(unwind-jump (tag-jump tag))))
(defun c2throw (c1form tag val &aux loc)
(declare (ignore c1form))
(case (c1form-name tag)
((VARIABLE LOCATION) (setq loc (c1form-arg 0 tag)))
(t (setq loc (make-temp-var))
((VARIABLE LOCATION)
(setq loc (c1form-arg 0 tag)))
(t
(setq loc (make-temp-var))
(let ((*destination* loc))
(c2expr* tag))))
(let ((*destination* 'VALUEZ))
(c2expr* val))
(wt-nl "cl_throw(" loc ");"))
(unwind-flee loc :throw))
(defun c2catch (c1form tag body)
(declare (ignore c1form))

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

@ -76,22 +76,6 @@
(declare (si::c-local))
(and (consp dest) (eq (si:cons-car dest) 'JUMP-FALSE)))
(defun negate-argument (inlined-arg dest-loc)
(declare (si::c-local))
(let* ((loc (second inlined-arg))
(rep-type (loc-representation-type loc)))
(apply #'produce-inline-loc
(list inlined-arg)
(if (eq (loc-representation-type dest-loc) :bool)
(case rep-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
(: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*)))))))
(defun c2fmla-not (c1form arg)
(declare (ignore c1form))
(let ((dest *destination*))
@ -102,10 +86,8 @@
(let ((*destination* `(JUMP-TRUE ,@(cdr dest))))
(c2expr arg)))
(t
(let ((*inline-blocks* 0)
(*temp* *temp*))
(unwind-exit (negate-argument (emit-inline-form arg nil) dest))
(close-inline-blocks))))))
(with-inline-blocks ()
(unwind-exit (negate-argument arg dest)))))))
(defun c2fmla-and (c1form butlast last)
(declare (ignore c1form))
@ -137,8 +119,7 @@
(dolist (f butlast)
(let ((*destination* 'VALUE0))
(c2expr* f))
(wt-nl "if (" 'VALUE0 "!=ECL_NIL) ")
(wt-open-brace) (unwind-jump normal-exit) (wt-nl-close-brace))
(unwind-cond normal-exit :jump-t 'VALUE0))
(c2expr last))
(unwind-exit 'VALUE0)))))
@ -156,51 +137,50 @@
(defun c2values (c1form forms)
(declare (ignore c1form))
(cond
;; When the values are not going to be used, then just
;; process each form separately.
((eq *destination* 'TRASH)
(mapc #'c2expr* forms)
;; We really pass no value, but we need UNWIND-EXIT to trigger all the
;; frame-pop and all other exit forms.
(unwind-exit 'VALUE0))
;; For (VALUES) we can replace the output with either NIL (if the value is
;; actually used) and set only NVALUES when the value is the output of a
;; function.
((endp forms)
(cond ((eq *destination* 'LEAVE)
(wt-nl "value0 = ECL_NIL;")
(wt-nl "cl_env_copy->nvalues = 0;")
(unwind-exit 'LEAVE))
((eq *destination* 'VALUEZ)
(wt-nl "cl_env_copy->values[0] = ECL_NIL;")
(wt-nl "cl_env_copy->nvalues = 0;")
(unwind-exit 'VALUEZ))
(t
(unwind-exit *vv-nil*))))
;; For a single form, we must simply ensure that we only take a single
;; value of those that the function may output.
((endp (rest forms))
(let ((form (first forms)))
(if (or (not (member *destination* '(LEAVE VALUEZ)))
(c1form-single-valued-p form))
(c2expr form)
(progn
(let ((*destination* 'VALUE0)) (c2expr* form))
(unwind-exit 'VALUE0)))))
;; In all other cases, we store the values in the VALUES vector,
;; and force the compiler to retrieve anything out of it.
(t
(let* ((nv (length forms))
(*inline-blocks* 0)
(*temp* *temp*)
(forms (nreverse (coerce-locs (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 ";")
(do ((vl forms (rest vl))
(i (1- (length forms)) (1- i)))
((null vl))
(declare (fixnum i))
(wt-nl "cl_env_copy->values[" i "] = " (first vl) ";"))
(unwind-exit 'VALUEZ)
(close-inline-blocks)))))
;; When the values are not going to be used, then just process each form
;; separately.
((eq *destination* 'TRASH)
(mapc #'c2expr* forms)
;; We really pass no value, but we need UNWIND-EXIT to trigger all the
;; frame-pop and all other exit forms.
(unwind-exit 'VALUE0))
;; For (VALUES) we can replace the output with either NIL (if the value is
;; actually used) and set only NVALUES when the value is the output of a
;; function.
((endp forms)
(case *destination*
(VALUEZ
(wt-nl "cl_env_copy->values[0] = ECL_NIL;")
(wt-nl "cl_env_copy->nvalues = 0;")
(unwind-exit 'VALUEZ))
(LEAVE
(wt-nl "value0 = ECL_NIL;")
(wt-nl "cl_env_copy->nvalues = 0;")
(unwind-exit 'LEAVE))
(otherwise (unwind-exit *vv-nil*))))
;; For a single form, we must simply ensure that we only take a single
;; value of those that the function may output.
((endp (rest forms))
(let ((form (first forms)))
(if (or (not (member *destination* '(LEAVE VALUEZ)))
(c1form-single-valued-p form))
(c2expr form)
(progn
(let ((*destination* 'VALUE0))
(c2expr* form))
(unwind-exit 'VALUE0)))))
;; In all other cases, we store the values in the VALUES vector,
;; and force the compiler to retrieve anything out of it.
(t
(with-inline-blocks ()
(let* ((nv (length forms))
(forms (nreverse (coerce-locs (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 ";")
(do ((vl forms (rest vl))
(i (1- (length forms)) (1- i)))
((null vl))
(declare (fixnum i))
(wt-nl "cl_env_copy->values[" i "] = " (first vl) ";"))
(unwind-exit 'VALUEZ))))))

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

@ -13,8 +13,10 @@
;;;;
;;;; The exit manager has two main operators that unwind the dynamic context:
;;;;
;;;; (UNWIND-EXIT value) carries VALUE to *DESTINATION* and unwinds to *EXIT*.
;;;; (UNWIND-JUMP label) unwinds to LABEL.
;;;; (UNWIND-EXIT value) carries VALUE to *DESTINATION* and unwinds to *EXIT*
;;;; (UNWIND-JUMP label) unwinds to LABEL
;;;; (UNWIND-COND label) unwinds to LABEL (conditionally)
;;;; (UNWIND-FLEE label) escapes to LABEL (runtime unwind)
;;;;
(in-package "COMPILER")
@ -33,10 +35,18 @@
(t (baboon-exit-invalid *exit*)))))
(defun unwind-jump (exit)
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
(compute-unwind (label-denv exit))
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
(wt-nl-go exit)))
(%unwind (label-denv exit) *unwind-exit*)
(%goto exit))
(defun unwind-cont (exit)
(%unwind (label-denv exit) *unwind-exit*)
(%goto exit))
(defun unwind-flee (exit kind)
(%escape exit kind))
(defun unwind-cond (exit kind &rest args)
(%branch exit *unwind-exit* kind args))
;;;
@ -48,9 +58,9 @@
(baboon :format-control "The value of exit~%~A~%is not valid."
:format-arguments (list exit)))
(defun baboon-unwind-invalid (unwind-exit)
(baboon :format-control "The value~%~A~%is not a tail of *UNWIND-EXIT*~%~A"
:format-arguments (list unwind-exit *unwind-exit*)))
(defun baboon-unwind-invalid (unwind-to unwind-from)
(baboon :format-control "The unwind value~%~A~%is not a tail of the unwind value~%~A"
:format-arguments (list unwind-to unwind-from)))
(defun baboon-unwind-exit (exit)
(baboon :format-control "The value of exit~%~A~%found in *UNWIND-EXIT*~%~A~%is not valid."
@ -73,26 +83,10 @@
;;; LEAVE -> outermost location
;;; #<label id used-p> -> label (basic block leader)
(defun perform-unwind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
(declare (si::c-local)
(fixnum frs-bind bds-bind))
(when (plusp frs-bind)
(wt-nl "ecl_frs_pop_n(cl_env_copy, " frs-bind ");"))
(when stack-frame
(wt-nl "ecl_stack_frame_close(" stack-frame ");"))
(when bds-lcl
(wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");"))
(if (< bds-bind 4)
(dotimes (n bds-bind)
(declare (ignorable n))
(wt-nl "ecl_bds_unwind1(cl_env_copy);"))
(wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))
(case ihs-p
(IHS (wt-nl "ecl_ihs_pop(cl_env_copy);"))
(IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;"))))
(defun compute-unwind (last-cons)
(defun compute-unwind (unwind-to unwind-from)
(declare (si::c-local))
(unless (tailp unwind-to unwind-from)
(baboon-unwind-invalid unwind-to unwind-from))
(loop with bds-lcl = nil
with bds-bind = 0
with stack-frame = nil
@ -100,9 +94,9 @@
with frs-bind = 0
with jump-p = nil
with exit-p = nil
for unwind-exit on *unwind-exit*
for unwind-exit on unwind-from
for ue = (car unwind-exit)
until (eq unwind-exit last-cons)
until (eq unwind-exit unwind-to)
do (cond
((consp ue)
(case (first ue)
@ -126,47 +120,34 @@
(defun unwind-leave (loc)
(declare (si::c-local))
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
(compute-unwind nil)
(declare (fixnum frs-bind bds-bind))
;; *destination* must be either LEAVE or TRASH.
(cond ((eq loc 'VALUEZ)
;; from multiple-value-prog1 or values
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return cl_env_copy->values[0];"))
((eq loc 'LEAVE)
;; from multiple-value-prog1 or values
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return value0;"))
(t
(set-loc 'LEAVE loc)
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return value0;")))))
;; *destination* must be either LEAVE or TRASH.
(unless (member loc '(VALUEZ LEAVE))
(set-loc 'LEAVE loc)
(setf loc 'LEAVE))
(%unwind nil *unwind-exit*)
(%exit loc))
(defun unwind-label (loc)
(declare (si::c-local))
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p jump-p exit-p)
(compute-unwind (or (member *exit* *unwind-exit* :test #'eq)
(baboon-exit-not-found *exit*)))
(declare (fixnum frs-bind bds-bind))
;; This operator does not cross the function boundary.
(assert (null exit-p))
(cond ((and (destination-value-matters-p *destination*)
(or (plusp frs-bind) bds-lcl (plusp bds-bind) stack-frame)
(or (loc-refers-to-special-p loc)
(loc-refers-to-special-p *destination*)))
;; Save the value if LOC may possibly refer to special binding.
(let* ((*temp* *temp*)
(temp (make-temp-var)))
(set-loc temp loc)
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
(set-loc *destination* temp)))
(t
(set-loc *destination* loc)
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)))
;; When JUMP-P is NULL then we "fall through" onto the exit block.
(when jump-p
(wt-nl-go *exit*))))
(let* ((exit *exit*)
(dest *destination*)
(from *unwind-exit*)
(exit-denv (member exit from :test #'eq)))
(unless exit-denv
(baboon-exit-not-found exit))
(if (and (destination-value-matters-p dest)
(loc-refers-to-special-p dest))
;; Save the value if destination may possibly refer to a special
;; binding. Otherwise we set the destination /before/ the unwind.
(let* ((*temp* *temp*)
(temp (make-temp-var)))
(set-loc temp loc)
(%unwind exit-denv from)
(set-loc dest temp))
(progn
(set-loc dest loc)
(%unwind exit-denv from)))
(%jump exit from)))
;;; Conditional JUMP based on the value of *DESTINATION*. This allows FMLA to
;;; jump over *EXIT* to skip the dead part of the computation. -- jd 2023-11-16
@ -177,25 +158,102 @@
(ecase target
(JUMP-TRUE
(cond ((not constantp)
(case (loc-representation-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) ")))
(wt-open-brace) (unwind-jump label) (wt-nl-close-brace))
(unwind-cond label :jump-t loc))
((not (null value))
(unwind-jump label)))
(unless (and constantp (not (null value)))
(let ((*destination* 'TRASH))
(unwind-exit *vv-nil*))))
(if (labelp *exit*)
(unwind-label *vv-nil*)
(unwind-leave *vv-nil*)))))
(JUMP-FALSE
(cond ((not constantp)
(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 ")) ")))
(wt-open-brace) (unwind-jump label) (wt-nl-close-brace))
(unwind-cond label :jump-f loc))
((null value)
(unwind-jump label)))
(unless (and constantp (null value))
(let ((*destination* 'TRASH))
(unwind-exit *vv-t*))))))))
(if (labelp *exit*)
(unwind-label *vv-t*)
(unwind-leave *vv-t*)))))))))
;;; Helper functions
;;;
;;; These functions will be moved to codegen.
;;; INV this function arguments are procured by COMPUTE-UNWIND.
(defun perform-unwind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
(declare (si::c-local)
(fixnum frs-bind bds-bind))
(when (plusp frs-bind)
(wt-nl "ecl_frs_pop_n(cl_env_copy, " frs-bind ");"))
(when stack-frame
(wt-nl "ecl_stack_frame_close(" stack-frame ");"))
(when bds-lcl
(wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");"))
(if (< bds-bind 4)
(dotimes (n bds-bind)
(declare (ignorable n))
(wt-nl "ecl_bds_unwind1(cl_env_copy);"))
(wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))
(case ihs-p
(IHS (wt-nl "ecl_ihs_pop(cl_env_copy);"))
(IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;"))))
(defun %unwind (into from)
(declare (si::c-local))
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
(compute-unwind into from)
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)))
(defun %branch (exit from kind args)
(ecase kind
(:jump-t
(destructuring-bind (loc) args
(case (loc-representation-type loc)
(:bool (wt-nl "if (" loc ") "))
(:object (wt-nl "if (" loc "!=ECL_NIL) "))
(otherwise (wt-nl "if ((") (wt-coerce-loc :object loc) (wt ")!=ECL_NIL) ")))))
(:jump-f
(destructuring-bind (loc) args
(case (loc-representation-type loc)
(:bool (wt-nl "if (!(" loc ")) "))
(:object (wt-nl "if (Null(" loc ")) "))
(otherwise (wt-nl "if (Null(") (wt-coerce-loc :object loc) (wt ")) ")))))
(:jump-eq
(destructuring-bind (x y) args
(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)
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
(wt-nl-go exit))
(wt-nl-close-brace))
(defun %escape (exit kind)
;; All these boil down to calling ecl_unwind which unwinds stacks dynamically.
;; If we want to implement call/cc, then this is the place where we dispatch.
#+ (or) (wt-nl "ecl_unwind(cl_env_copy," frs-id ");")
(ecase kind
(:go
;; The second argument is passed as a value (index for jump).
(wt-nl "cl_go(" (tag-var exit) ",ecl_make_fixnum(" (tag-index exit) "));"))
(:throw
;; Unlike GO and RETURN-FROM, the destination is not known at compile time.
;; TODO in some cases it is possible to prove the destination CATCH form.
(wt-nl "cl_throw(" exit ");"))
(:return-from
;; The second argument is used only to signal the error.
(wt-nl "cl_return_from(" (blk-var exit) "," (get-object (blk-name exit)) ");"))))
;;; JUMP is similar to %GOTO, but it allows a fallthough.
(defun %jump (label from)
(unless (eq label (find-if #'labelp from))
(wt-nl-go label)))
(defun %goto (label)
(wt-nl-go label))
(defun %exit (loc)
(wt-nl "return " loc ";"))

48
src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp
View file

@ -61,49 +61,5 @@
(defun c2c-inline (c1form arguments &rest rest)
(declare (ignore c1form))
(let ((*inline-blocks* 0)
(*temp* *temp*))
(unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest))
(close-inline-blocks)))
(defun t3-defcallback (lisp-name c-name c-name-constant return-type return-type-code
arg-types arg-type-constants call-type &aux (return-p t))
(declare (ignore lisp-name))
(when (eql return-type :void)
(setf return-p nil))
(let ((return-type-name (rep-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
((:cdecl :default) "")
(:stdcall "__stdcall ")
(t (cmperr "DEFCALLBACK does not support ~A as calling convention"
call-type)))))
(wt-nl-h "static " return-type-name " " fmod c-name "(")
(wt-nl1 "static " return-type-name " " fmod c-name "(")
(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))
do (wt-h comma arg-type-name " " var)
(wt comma arg-type-name " " var)
(setf comma ","))
(wt ")")
(wt-h ");")
(with-lexical-scope ()
(when return-p
(wt-nl return-type-name " output;"))
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
(wt-nl "cl_object aux;")
(with-stack-frame (frame)
(loop for var in vars
and type in arg-types
and ct in arg-type-constants
do (wt-nl "ecl_stack_frame_push(" frame "," `(ffi-data-ref ,var ,ct) ");"))
(wt-nl "aux = ecl_apply_from_stack_frame(" frame ","
"ecl_fdefinition(" c-name-constant "));")
;; No UNWIND-EXIT, so we must close the frame manually.
(wt-nl "ecl_stack_frame_close(" frame ");"))
(when return-p
(set-loc `(ffi-data-ref "output" ,return-type-code) "aux")
(wt-nl "return output;")))))
(with-inline-blocks ()
(unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest))))

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

@ -403,7 +403,7 @@
(progn
(wt-nl)
(wt-loc destination) (wt " = ")
(wt-coerce-loc (loc-representation-type *destination*) loc)
(wt-coerce-loc (loc-representation-type destination) loc)
(wt ";"))))))
(defun set-the-loc (loc type orig-loc)

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

@ -44,6 +44,55 @@
(apply def form (c1form-args form)))
(cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form)))
(defun t2compiler-let (c1form symbols values body)
(declare (ignore c1form))
(progv symbols values (c2expr body)))
(defun t2progn (c1form args)
(declare (ignore c1form))
(mapc #'t2expr args))
(defun t2ordinary (c1form form)
(declare (ignore c1form))
(with-exit-label (*exit*)
(let ((*destination* 'TRASH))
(c2expr form))))
(defun t2load-time-value (c1form vv-loc form)
(declare (ignore c1form))
(with-exit-label (*exit*)
(let ((*destination* vv-loc))
(c2expr form))))
(defun t2make-form (c1form vv-loc form)
(declare (ignore c1form))
(with-exit-label (*exit*)
(let ((*destination* vv-loc))
(c2expr form))))
(defun t2init-form (c1form vv-loc form)
(declare (ignore c1form vv-loc))
(with-exit-label (*exit*)
(let ((*destination* 'TRASH))
(c2expr form))))
(defun t2fset (c1form &rest args)
(declare (ignore args))
(t2ordinary c1form c1form))
(defun c2fset (c1form fun fname macro-p pprint c1forms)
(declare (ignore pprint))
(when (fun-no-entry fun)
(wt-nl "(void)0; " (format nil "/* No entry created for ~A */" (fun-name fun)))
;; FIXME! Look at C2LOCALS!
(update-function-env fun)
(return-from c2fset))
(if (and (not (fun-closure fun))
(eq *destination* 'TRASH))
(wt-install-function fname fun macro-p)
(c2call-global c1form 'SI:FSET c1forms)))
(defun emit-functions (*compiler-output1*)
(declare (si::c-local))
;; Local functions and closure functions
@ -60,49 +109,7 @@
;; so disassemble can redefine it
(t3function (first lfs)))))))
(defun emit-entry-fun (name *compiler-output1*)
(let* ((*opened-c-braces* 0)
(*aux-closure* nil))
(wt-nl "ECL_DLLEXPORT void " name "(cl_object flag)")
(wt-nl-open-brace)
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
(wt-nl "cl_object value0;")
(wt-nl "cl_object *VVtemp;")
(wt-nl "if (flag != OBJNULL){")
(wt-nl "Cblock = flag;")
(wt-nl "#ifndef ECL_DYNAMIC_VV")
(wt-nl "flag->cblock.data = VV;")
(wt-nl "#endif")
(when *self-destructing-fasl*
(wt-nl "flag->cblock.self_destruct=1;"))
(wt-nl "flag->cblock.data_size = VM;")
(wt-nl "flag->cblock.temp_data_size = VMtemp;")
(wt-nl "flag->cblock.data_text = compiler_data_text;")
(wt-nl "flag->cblock.cfuns_size = compiler_cfuns_size;")
(wt-nl "flag->cblock.cfuns = compiler_cfuns;")
(when ext:*source-location*
(wt-nl "flag->cblock.source = ecl_make_constant_base_string(\""
(namestring (car ext:*source-location*)) "\",-1);"))
(wt-nl "return;}")
(wt-nl "#ifdef ECL_DYNAMIC_VV")
(wt-nl "VV = Cblock->cblock.data;")
(wt-nl "#endif")
;; With this we ensure creating a constant with the tag
;; and the initialization file
(wt-nl "Cblock->cblock.data_text = (const cl_object *)\"" (init-name-tag name) "\";")
(wt-nl "VVtemp = Cblock->cblock.temp_data;")
(wt-nl "ECL_DEFINE_SETF_FUNCTIONS")
(dolist (form *make-forms*)
(emit-toplevel-form form))
(dolist (form *top-level-forms*)
(emit-toplevel-form form))
;; We process top-level forms before functions to update their
;; environments. Then we emit functions before top level forms.
(wt-nl-close-many-braces 0)))
(defun ctop-write (init-name h-pathname data-pathname
&aux def top-output-string (*volatile* "volatile "))
(defun ctop-write (init-name h-pathname data-pathname &aux top-output-string)
(wt-nl "#include \"" (brief-namestring h-pathname) "\"")
;; VV might be needed by functions in CLINES.
@ -119,7 +126,7 @@
;;; We rebind the output to ensure that the initialization function is
;;; processed first and added last.
(let ((output (make-string-output-stream)))
(emit-entry-fun init-name output)
(t3entry-fun init-name output)
(emit-functions *compiler-output1*)
(setq top-output-string (get-output-stream-string output)))
;; Declarations in h-file.
@ -160,7 +167,7 @@
(when *callbacks*
(wt-nl-h "#include <ecl/internal.h>")
(dolist (x *callbacks*)
(apply #'t3-defcallback x)))
(apply #'t3callback x)))
(wt-nl "#include \"" (brief-namestring data-pathname) "\"")
(wt-nl "#ifdef __cplusplus")
@ -168,43 +175,6 @@
(wt-nl "#endif")
(wt-nl top-output-string))
(defun emit-toplevel-form (form)
(declare (si::c-local))
(let ((*ihs-used-p* nil)
(*max-lex* 0)
(*max-env* 0)
(*max-temp* 0)
(*lcl* 0)
(*lex* 0)
(*level* 0)
(*env* 0)
(*env-lvl* 0)
(*temp* 0)
(*compile-to-linking-call* nil)
(*compile-file-truename* (and form (c1form-file form)))
(*compile-file-position* (and form (c1form-file-position form))))
;; We save the C body of the statement, indented, just in case
;; we need to add a {} section with the environment variables.
(let ((body (let ((*opened-c-braces* (1+ *opened-c-braces*)))
(with-output-to-string (*compiler-output1*)
(t2expr form)))))
(if (or (plusp *max-lex*)
(plusp *max-temp*)
(plusp *max-env*)
*ihs-used-p*)
(with-lexical-scope ()
(wt-function-locals)
(write-sequence body *compiler-output1*))
(write-sequence body *compiler-output1*)))))
(defun t2compiler-let (c1form symbols values body)
(declare (ignore c1form))
(progv symbols values (c2expr body)))
(defun t2progn (c1form args)
(declare (ignore c1form))
(mapc #'t2expr args))
(defun wt-function-locals (&optional closure-type)
;; FIXME! Are we careful enough with temporary variables that
;; we need not make them volatile?
@ -239,30 +209,104 @@
do (wt comma "CLV" i)
finally (wt ";"))))
(defun t3entry-fun (name *compiler-output1*)
(with-bir-env (:env 0 :level 0 :volatile "volatile ")
(wt-nl "ECL_DLLEXPORT void " name "(cl_object flag)")
(wt-nl-open-brace)
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
(wt-nl "cl_object value0;")
(wt-nl "cl_object *VVtemp;")
(defun t2ordinary (c1form form)
(declare (ignore c1form))
(with-exit-label (*exit*)
(let ((*destination* 'TRASH))
(c2expr form))))
(wt-nl "if (flag != OBJNULL){")
(wt-nl "Cblock = flag;")
(wt-nl "#ifndef ECL_DYNAMIC_VV")
(wt-nl "flag->cblock.data = VV;")
(wt-nl "#endif")
(when *self-destructing-fasl*
(wt-nl "flag->cblock.self_destruct=1;"))
(wt-nl "flag->cblock.data_size = VM;")
(wt-nl "flag->cblock.temp_data_size = VMtemp;")
(wt-nl "flag->cblock.data_text = compiler_data_text;")
(wt-nl "flag->cblock.cfuns_size = compiler_cfuns_size;")
(wt-nl "flag->cblock.cfuns = compiler_cfuns;")
(when ext:*source-location*
(wt-nl "flag->cblock.source = ecl_make_constant_base_string(\""
(namestring (car ext:*source-location*)) "\",-1);"))
(wt-nl "return;}")
(wt-nl "#ifdef ECL_DYNAMIC_VV")
(wt-nl "VV = Cblock->cblock.data;")
(wt-nl "#endif")
;; With this we ensure creating a constant with the tag
;; and the initialization file
(wt-nl "Cblock->cblock.data_text = (const cl_object *)\"" (init-name-tag name) "\";")
(wt-nl "VVtemp = Cblock->cblock.temp_data;")
(wt-nl "ECL_DEFINE_SETF_FUNCTIONS")
;; We save the C body of the statement, indented, just in case we need to
;; add a {} section with the environment variables.
(let ((body (let ((*opened-c-braces* (1+ *opened-c-braces*)))
(with-output-to-string (*compiler-output1*)
(terpri *compiler-output1*)
(wt-comment-nl "MAKE-LOAD-FORMs")
(dolist (form *make-forms*)
(t2expr form))
(wt-comment-nl "TOP-LEVEL-FORMs")
(dolist (form *top-level-forms*)
(t2expr form))))))
(if (or (plusp *max-lex*)
(plusp *max-temp*)
(plusp *max-env*)
*ihs-used-p*)
(with-lexical-scope ()
(wt-function-locals)
(write-sequence body *compiler-output1*))
(write-sequence body *compiler-output1*)))
;; We process top-level forms before functions to update their
;; environments. Then we emit functions before top level forms.
(wt-nl-close-many-braces 0)))
(defun t2load-time-value (c1form vv-loc form)
(declare (ignore c1form))
(with-exit-label (*exit*)
(let ((*destination* vv-loc))
(c2expr form))))
(defun t2make-form (c1form vv-loc form)
(declare (ignore c1form))
(with-exit-label (*exit*)
(let ((*destination* vv-loc))
(c2expr form))))
(defun t2init-form (c1form vv-loc form)
(declare (ignore c1form vv-loc))
(with-exit-label (*exit*)
(let ((*destination* 'TRASH))
(c2expr form))))
(defun t3callback (lisp-name c-name c-name-constant return-type return-type-code
arg-types arg-type-constants call-type &aux (return-p t))
(declare (ignore lisp-name))
(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)))
(vars (loop for n from 0 below (length arg-types)
collect (format nil "var~d" n)))
(fmod (case call-type
((:cdecl :default) "")
(:stdcall "__stdcall ")
(t (cmperr "DEFCALLBACK does not support ~A as calling convention"
call-type)))))
(wt-nl-h "static " return-type-name " " fmod c-name "(")
(wt-nl1 "static " return-type-name " " fmod c-name "(")
(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))
do (wt-h comma arg-type-name " " var)
(wt comma arg-type-name " " var)
(setf comma ","))
(wt ")")
(wt-h ");")
(with-lexical-scope ()
(when return-p
(wt-nl return-type-name " output;"))
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
(wt-nl "cl_object aux;")
(with-stack-frame (frame)
(loop for var in vars
and type in arg-types
and ct in arg-type-constants
do (wt-nl "ecl_stack_frame_push(" frame "," `(ffi-data-ref ,var ,ct) ");"))
(wt-nl "aux = ecl_apply_from_stack_frame(" frame ","
"ecl_fdefinition(" c-name-constant "));")
;; No UNWIND-EXIT, so we must close the frame manually.
(wt-nl "ecl_stack_frame_close(" frame ");"))
(when return-p
(set-loc `(ffi-data-ref "output" ,return-type-code) "aux")
(wt-nl "return output;"))))))
(defun t3function (fun)
(declare (type fun fun))
@ -272,35 +316,25 @@
(format t "~&;;; Emitting code for ~s.~%" name)))
(let* ((lambda-expr (fun-lambda fun))
(*cmp-env* (c1form-env lambda-expr))
(*lcl* 0) (*temp* 0) (*max-temp* 0)
(*last-label* 0)
(*lex* 0) (*max-lex* 0)
(*env* (fun-env fun)) ; continue growing env
(*max-env* *env*) (*env-lvl* 0)
(*aux-closure* nil)
(*level* (fun-lexical-levels fun))
(*exit* 'LEAVE)
(*unwind-exit* '(LEAVE))
(*destination* *exit*)
(*ihs-used-p* nil)
(*opened-c-braces* 0)
(*tail-recursion-info* fun)
(*tail-recursion-mark* nil)
(*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))))
(*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
@ -328,7 +362,6 @@
(or (fun-name fun) (fun-description fun) 'CLOSURE))
(let* ((comma "")
(lambda-expr (fun-lambda fun))
(volatile (c1form-volatile* lambda-expr))
(lambda-list (c1form-arg 0 lambda-expr))
(requireds (loop
repeat si::c-arguments-limit
@ -349,16 +382,16 @@
(wt-nl-h "static cl_object " cfun "(")
(wt-nl "static cl_object " cfun "("))))
(when narg
(wt-h volatile "cl_narg")
(wt volatile "cl_narg narg")
(wt-h *volatile* "cl_narg")
(wt *volatile* "cl_narg narg")
(setf comma ", "))
(dotimes (n (fun-lexical-levels fun))
(wt-h comma "volatile cl_object *")
(wt comma "volatile cl_object *lex" n)
(setf comma ", "))
(loop for lcl in (setf (fun-required-lcls fun) requireds)
do (wt-h comma "cl_object " volatile)
(wt comma "cl_object " volatile lcl)
do (wt-h comma "cl_object " *volatile*)
(wt comma "cl_object " *volatile* lcl)
(setf comma ", "))
(when narg
(wt-h ", ...")
@ -433,29 +466,12 @@
(format stream "~%};")))))
(defun wt-install-function (fname fun macro-p)
(let ((*inline-blocks* 0)
(loc (data-empty-loc*)))
(push (list loc fname fun) *global-cfuns-array*)
;; FIXME! Look at C2LOCALS!
(update-function-env fun)
(if macro-p
(wt-nl "ecl_cmp_defmacro(" loc ");")
(wt-nl "ecl_cmp_defun(" loc ");"))
(wt-comment (loc-immediate-value fname))
(close-inline-blocks)))
(defun t2fset (c1form &rest args)
(declare (ignore args))
(t2ordinary c1form c1form))
(defun c2fset (c1form fun fname macro-p pprint c1forms)
(declare (ignore pprint))
(when (fun-no-entry fun)
(wt-nl "(void)0; " (format nil "/* No entry created for ~A */" (fun-name fun)))
;; FIXME! Look at C2LOCALS!
(update-function-env fun)
(return-from c2fset))
(if (and (not (fun-closure fun))
(eq *destination* 'TRASH))
(wt-install-function fname fun macro-p)
(c2call-global c1form 'SI:FSET c1forms)))
(with-inline-blocks ()
(let ((loc (data-empty-loc*)))
(push (list loc fname fun) *global-cfuns-array*)
;; FIXME! Look at C2LOCALS!
(update-function-env fun)
(if macro-p
(wt-nl "ecl_cmp_defmacro(" loc ");")
(wt-nl "ecl_cmp_defun(" loc ");"))
(wt-comment (loc-immediate-value fname)))))

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

@ -304,14 +304,12 @@
;; Binding these variables is complicated and involves lexical
;; environments, global environments, etc. If we use `(BIND var)
;; as destination, BIND might receive the wrong environment.
(let* ((*inline-blocks* 0)
(*temp* *temp*)
(locs (coerce-locs (inline-args (list form)))))
(bind (first locs) var)
(close-inline-blocks)
;; Notice that we do not need to update *UNWIND-EXIT*
;; because BIND does it for us.
)
(with-inline-blocks ()
(let ((locs (coerce-locs (inline-args (list form)))))
(bind (first locs) var)
;; Notice that we do not need to update *UNWIND-EXIT* because BIND
;; does it for us.
))
;; The simple case of a variable which is local to a function.
(let ((*destination* `(BIND ,var)))
(c2expr* form)))))

11
src/cmp/cmpglobals.lsp
View file

@ -71,10 +71,6 @@ running the compiler. It may be updated by running ")
(defvar *machine* nil)
;;; --cmpcall.lsp--
;;;
;;; Whether to use linking calls.
;;;
(defvar *compile-to-linking-call* t)
(defvar *compiler-declared-globals*)
;;; --cmpenv.lsp--
@ -124,13 +120,6 @@ variable, block, tag or function object at the end.")
only be altered by DECLAIM forms and it is used to initialize the
value of *CMP-ENV*.")
;;; --cmplocs.lsp--
;;;
;;; Destination of output of different forms. See cmplocs.lsp for types of
;;; destinations.
;;;
(defvar *destination*)
;;; --cmpmain.lsp--
;;;
;;; Do we debug the compiler? Then we need files not to be deleted.

42
src/cmp/cmplocs.lsp
View file

@ -99,16 +99,17 @@
(otherwise NIL)))
(defun loc-refers-to-special-p (loc)
(when (atom loc)
(return-from loc-refers-to-special-p
(and (var-p loc)
(member (var-kind loc) '(SPECIAL GLOBAL)))))
(case (first loc)
(CL:THE (loc-refers-to-special-p (third loc)))
(BIND T)
;; We do not know, so guess yes.
(FFI:C-INLINE T)
(otherwise NIL)))
(flet ((special-var-p (loc)
(and (var-p loc)
(member (var-kind loc) '(SPECIAL GLOBAL)))))
(if (atom loc)
(special-var-p loc)
(case (first loc)
(CL:THE (loc-refers-to-special-p (third loc)))
(BIND (special-var-p (second loc)))
;; We do not know, so guess yes.
(FFI:C-INLINE T)
(otherwise NIL)))))
;;; Valid locations are:
;;; VALUE0
@ -135,25 +136,6 @@
;;; VA-ARG
;;; CL-VA-ARG
;;; Valid *DESTINATION* locations are:
;;;
;;; var-object Variable
;;; loc-object VV Location
;;; TRASH Value may be thrown away.
;;; LEAVE Object returned from current function.
;;; VALUEZ Values vector.
;;; VALUE0
;;; ( VALUE i ) Nth value
;;; ( BIND var alternative ) Alternative is optional
;;; ( JUMP-TRUE label )
;;; ( JUMP-FALSE label )
(defun tmp-destination (loc)
(case loc
(VALUEZ 'VALUEZ)
(TRASH 'TRASH)
(T 'LEAVE)))
(defun precise-loc-type (loc new-type)
(if (subtypep (loc-type loc) new-type)
loc
@ -183,7 +165,7 @@
(defun uses-values (loc)
(and (consp loc)
(or (member (car loc) '(CALL CALL-NORMAL CALL-INDIRECT CALL-STACK) :test #'eq)
(or (member (car loc) '(CALL-NORMAL CALL-INDIRECT CALL-STACK) :test #'eq)
(and (eq (car loc) 'ffi:C-INLINE)
(eq (sixth loc) 'cl:VALUES)))))

3
src/cmp/cmpopt-num.lsp
View file

@ -184,6 +184,9 @@
:format-arguments (list operator (or whole
(list* operator args)))))))))
;;; INV These compiler macros are expected to be in effect by C inliners
;;; defined for corresponding operators. -- jd 2023-12-04
(define-compiler-macro * (&whole all &rest args)
(simplify-arithmetic '* args all))

1
src/cmp/cmppackage.lsp
View file

@ -19,7 +19,6 @@
;; Flags controlling the compiler behavior.
"*COMPILER-BREAK-ENABLE*"
"*COMPILE-PRINT*"
"*COMPILE-TO-LINKING-CALL*"
"*COMPILE-VERBOSE*"
"*COMPILER-FEATURES*"
"*CC*"

14
src/cmp/cmppass1-call.lsp
View file

@ -238,14 +238,12 @@
:args (c1expr `(function ,fname)) (c1args* args) fun :local))
(defun c1call-global (fname args)
(let* ((forms (c1args* args)))
;; If all arguments are constants, try to precompute the function
;; value. We abort when the function signals an error or the value
;; is not printable.
(let ((value (c1call-constant-fold fname forms)))
(when value
(return-from c1call-global value)))
;; Otherwise emit a global function call
(let ((forms (c1args* args)))
;; If all arguments are constants, try to precompute the function value. We
;; abort when the function signals an error or the value is not printable.
(ext:when-let ((value (c1call-constant-fold fname forms)))
(return-from c1call-global value))
;; Otherwise emit a global function call.
(make-c1form* 'FCALL
:sp-change (function-may-change-sp fname)
:side-effects (function-may-have-side-effects fname)

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

@ -38,7 +38,7 @@
"~s: The function ~s was already defined." origin (car def))
(push (car def) fnames)
(let* ((name (car def))
(var (make-var :name name :kind :object))
(var (make-var :name (gensym) :kind :object))
(fun (make-fun :name name :var var)))
(cmp-env-register-function fun new-env)
(push (cons fun (cdr def)) defs)))

4
src/cmp/load.lsp.in
View file

@ -48,11 +48,11 @@
"src:cmp;cmpbackend-cxx;cmpc-util.lsp"
"src:cmp;cmpbackend-cxx;cmpc-mach.lsp"
"src:cmp;cmpbackend-cxx;cmpc-wt.lsp"
"src:cmp;cmpbackend-cxx;cmpc-inliner.lsp"
"src:cmp;cmpbackend-cxx;cmpc-arg-inl.lsp"
"src:cmp;cmpbackend-cxx;cmpc-fun-inl.lsp"
;; Inliner definitions
"src:cmp;cmpbackend-cxx;cmpc-inl-lspfun.lsp"
"src:cmp;cmpbackend-cxx;cmpc-inl-sysfun.lsp"
"src:cmp;cmpbackend-cxx;cmpc-opt-inl.lsp"
"src:cmp;cmpbackend-cxx;cmpc-opt-num.lsp"
"src:cmp;cmpbackend-cxx;cmpc-opt-ct.lsp"
"src:cmp;cmpbackend-cxx;cmpc-opt-printer.lsp"

4
src/compile.lsp.in
View file

@ -125,8 +125,8 @@
:system-p t :c-file t :data-file t :h-file t
;;:shared-data-file "build:ecl.sdat"
)))
#+CLOS
(let* ((c::*compile-to-linking-call* nil))
#+clos
(progn
(mapc #'proclaim +ecl-optimization-settings+)
(setq lsp-objects (append lsp-objects
(compile-if-old "build:clos;" +clos-module-files+