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' into 'develop'

Browse source 
cmp: further refactor

See merge request embeddable-common-lisp/ecl!311
This commit is contained in:
Marius Gerbershagen 2023-12-05 20:26:02 +00:00
commit 758ebc6230
31 changed files with 973 additions and 1131 deletions
Download patch file Download diff file Expand all files Collapse all files

9
src/c/compiler.d
View file

@ -31,9 +31,6 @@
/********************* EXPORTS *********************/
#define REGISTER_SPECIALS 1
#define IGNORE_DECLARATIONS 0
/* Flags for the compilation routines: */
/* + Push the output of this form */
#define FLAG_PUSH 1
@ -51,8 +48,6 @@
#define FLAG_LOAD 32
#define FLAG_COMPILE 64
#define ENV_RECORD_LOCATION(r) CADDDR(r)
#define ECL_SPECIAL_VAR_REF -2
#define ECL_UNDEFINED_VAR_REF -1
@ -350,9 +345,7 @@ static int
c_register_constant(cl_env_ptr env, cl_object c)
{
int n = c_search_constant(env, c);
return (n < 0)?
asm_constant(env, c) :
n;
return (n < 0) ? asm_constant(env, c) : n;
}
static void

15
src/c/interpreter.d
View file

@ -188,7 +188,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
VAR is the name of the variable for readability purposes.
*/
CASE(OP_VAR); {
int lex_env_index;
cl_fixnum lex_env_index;
GET_OPARG(lex_env_index, vector);
reg0 = ecl_lex_env_get_var(lex_env, lex_env_index);
THREAD_NEXT;
@ -258,7 +258,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
}
/* OP_PUSH
Pushes the object in VALUES(0).
Pushes the object in REG0.
*/
CASE(OP_PUSH); {
ECL_STACK_PUSH(the_env, reg0);
@ -439,8 +439,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
THREAD_NEXT;
}
/* OP_POPREQ
Checks the arguments list. If there are remaining arguments,
REG0 = T and the value is on the stack, otherwise REG0 = NIL.
Checks the arguments list.
If there are remaining arguments, REG0 = ARG, otherwise signal an error.
*/
CASE(OP_POPREQ); {
if (ecl_unlikely(frame_index >= frame->frame.size)) {
@ -450,8 +450,9 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
THREAD_NEXT;
}
/* OP_POPOPT
Checks the arguments list. If there are remaining arguments,
REG0 = T and the value is on the stack, otherwise REG0 = NIL.
Checks the arguments list.
If there are remaining arguments, REG0 = T and the value is on the stack,
otherwise REG0 = NIL.
*/
CASE(OP_POPOPT); {
if (frame_index >= frame->frame.size) {
@ -463,7 +464,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
THREAD_NEXT;
}
/* OP_NOMORE
No more arguments.
Asserts that there are no more arguments in the frame.
*/
CASE(OP_NOMORE); {
if (ecl_unlikely(frame_index < frame->frame.size))

28
src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp
View file

@ -528,33 +528,7 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS
")
;;; Code generation
(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source)
(with-cxx-env ()
;; After this step we still can add new objects, but objects that are
;; already stored in VV or VVtemp must not change the location.
(optimize-cxx-data *referenced-objects*)
(setq *compiler-phase* 't2)
(with-open-file (*compiler-output1* c-pathname :direction :output
:if-does-not-exist :create
:if-exists :supersede)
(wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version))
#-ecl-min
(multiple-value-bind (second minute hour day month year)
(get-decoded-time)
(declare (ignore second))
(wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute)
(wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type)))
(wt-comment-nl "Source: ~A" source)
(with-open-file (*compiler-output2* h-pathname :direction :output
:if-does-not-exist :create
:if-exists :supersede)
(wt-nl1 "#include " *cmpinclude*)
(ctop-write init-name h-pathname data-pathname)
(terpri *compiler-output1*)
(terpri *compiler-output2*)))
(data-c-dump data-pathname)))
;;; Code assembly
(defun compiler-pass/assemble-cxx (input-file output-file
&key

16
src/cmp/cmpbackend-cxx/cmpc-inliner.lsp
View file

@ -22,7 +22,7 @@
return-type ;;; Lisp type for the output
exact-return-type ;;; Only use this expansion when the output is
;;; declared to have a subtype of RETURN-TYPE
multiple-values ;;; Works with all destinations, including VALUES / RETURN
multiple-values ;;; Works with all destinations, including VALUEZ / LEAVE
expansion ;;; C template containing the expansion
one-liner ;;; Whether the expansion spans more than one line
)
@ -127,7 +127,7 @@
(defun inline-type-matches (inline-info arg-types return-type)
(when (and (not (inline-info-multiple-values inline-info))
(member *destination* '(VALUES RETURN)))
(member *destination* '(VALUEZ LEAVE)))
(return-from inline-type-matches nil))
(let* ((rts nil)
(number-max nil))
@ -215,7 +215,7 @@
(cmpnote "Ignoring form ~S" c-expression))
(wt-nl "value0 = ECL_NIL;")
(wt-nl "cl_env_copy->nvalues = 0;")
(return-from produce-inline-loc 'RETURN))
(return-from produce-inline-loc 'LEAVE))
;; If the form is a one-liner, we can simply propagate this expression until the
;; place where the value is used.
@ -225,12 +225,12 @@
,(if (equalp output-rep-type '((VALUES &REST T)))
'VALUES NIL))))
;; If the output is a in the VALUES vector, just write down the form and output
;; the location of the data.
;; If the output is a in the VALUES vector, just write down the form and
;; output the location of the data.
(when (equalp output-rep-type '((VALUES &REST T)))
(wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects
'VALUES)
(return-from produce-inline-loc 'VALUES))
(return-from produce-inline-loc 'VALUEZ))
;; Otherwise we have to set up variables for holding the output.
(flet ((make-output-var (type)
@ -245,9 +245,9 @@
(t
(loop for v in output-vars
for i from 0
do (let ((*destination* `(VALUE ,i))) (set-loc v)))
do (set-loc `(VALUE ,i) v))
(wt "cl_env_copy->nvalues = " (length output-vars) ";")
'VALUES))))))
'VALUEZ))))))
(defun coerce-locs (inlined-args &optional types args-to-be-saved)
;; INLINED-ARGS is a list of (TYPE LOCATION) produced by the

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

@ -42,17 +42,16 @@
(defun save-inline-loc (loc)
(let* ((rep-type (loc-representation-type (second loc)))
(temp (make-inline-temp-var (first loc) rep-type))
(*destination* temp))
(set-loc 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))))
(let ((*destination* temp)) (set-loc var))
(let ((temp (make-inline-temp-var value-type (var-rep-type var))))
(set-loc temp var)
(list value-type temp))
(list value-type var))))
@ -72,9 +71,8 @@
(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)))
(*destination* temp))
(set-loc loc)
(temp (make-inline-temp-var type (loc-representation-type loc))))
(set-loc temp loc)
(list type temp)))
(defun emit-inlined-progn (form forms)

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

@ -9,7 +9,7 @@
(defvar *inline-blocks* 0)
(defvar *opened-c-braces* 0)
(defvar *emitted-local-funs* nil)
(defvar *emitted-functions* nil)
(defvar *inline-information* nil)
;;; Compiled code uses the following kinds of variables:
@ -38,30 +38,27 @@
;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
;;; If possible, *tail-recursion-info* holds
;;; ( c1-lambda-form required-arg .... required-arg ),
;;; ( c1-lambda-form required-arg .... required-arg ),
;;; where each required-arg is a var-object.
(defvar *tail-recursion-info* nil)
(defvar *tail-recursion-mark* nil)
;;; --cmpexit.lsp--
;;;
;;; *last-label* holds the label# of the last used label.
;;; *exit* holds an 'exit', which is
;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
;; RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT,
;; RETURN-CSFLOAT, RETURN-CDFLOAT, RETURN-CLFLOAT or RETURN-OBJECT).
;; LABEL instance or LEAVE.
;;; *unwind-exit* holds a list consisting of:
;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
;; JUMP, BDS-BIND (each pushed for a single special binding), or a
;; LCL (which holds the bind stack pointer used to unbind).
;; LABEL instance, LEAVE, FRAME, JUMP, BDS-BIND (each pushed for a single
;; special binding), or a LCL (which holds the bind stack pointer used to
;; unbind).
;;;
(defvar *last-label* 0)
(defvar *exit*)
(defvar *unwind-exit*)
;;; 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 }*
(defvar *local-funs*) ; holds { fun }*
;;; T/NIL flag to determine whether one may generate lisp constant values as C
;;; structs.
@ -94,17 +91,18 @@
(*max-temp* 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)
(make-inline-information *machine*)))
(*setf-definitions* nil)
(*global-cfuns-array* nil)
(*local-funs* nil)
(*static-constants* nil)
(*optimizable-constants* (make-optimizable-constants *machine*))
(*permanent-objects* (make-array 128 :adjustable t :fill-pointer 0))
(*temporary-objects* (make-array 128 :adjustable t :fill-pointer 0)))
(*temporary-objects* (make-array 128 :adjustable t :fill-pointer 0))
(*compiler-declared-globals* (make-hash-table)))
,@body))
(defun-cached env-var-name (n) eql
@ -141,7 +139,7 @@
(plusp *env*)
(dolist (exit *unwind-exit*)
(case exit
(RETURN (return NIL))
(LEAVE (return NIL))
(BDS-BIND)
(t (return T))))))
@ -149,29 +147,64 @@
(let ((code (incf *next-cfun*)))
(format nil prefix code (lisp-to-c-name lisp-name))))
(defun next-label ()
(cons (incf *last-label*) nil))
(defun next-label* ()
(cons (incf *last-label*) t))
(defun labelp (x)
(and (consp x) (integerp (si:cons-car x))))
(defun maybe-next-label ()
(if (labelp *exit*)
*exit*
(next-label)))
(defmacro with-exit-label ((label) &body body)
`(let* ((,label (next-label))
(*unwind-exit* (cons ,label *unwind-exit*)))
(defmacro with-lexical-scope (() &body body)
`(progn
(wt-nl-open-brace)
,@body
(wt-label ,label)))
(wt-nl-close-brace)))
(defmacro with-optional-exit-label ((label) &body body)
`(let* ((,label (maybe-next-label))
(*unwind-exit* (adjoin ,label *unwind-exit*)))
,@body
(unless (eq ,label *exit*)
(wt-label ,label))))
;;; *LAST-LABEL* holds the label# of the last used label. This is used by the
;;; code generator to avoid duplicated labels in the same scope.
(defvar *last-label* 0)
;;; LABEL represents a destination for a possible control transfer. An unique ID
;;; is assigned to ensure that there are no two labels of the same name. DENV
;;; captures the dynamic environment of the label, so when we jump to the label
;;; we may unwind the dynamic state (see the exit manager). USED-P is a flag is
;;; set to T when the code "jumps" to the label. -- jd 2023-11-25
(defstruct (label (:predicate labelp))
id
denv
used-p)
(defun next-label (used-p)
(make-label :id (incf *last-label*) :denv *unwind-exit* :used-p used-p))
;;; This macro binds VAR to a label where forms may exit or jump.
;;; LABEL may be supplied to reuse a label when it exists.
(defmacro with-exit-label ((var &optional exit) &body body)
(ext:with-gensyms (reuse label)
`(let* ((,label ,exit)
(,reuse (labelp ,label))
(,var (if ,reuse ,label (next-label nil)))
(*unwind-exit* (adjoin ,var *unwind-exit*)))
,@body
(unless ,reuse
(wt-label ,var)))))
;;; This macro estabilishes a frame to handle dynamic escapes like GO, THROW and
;;; RETURN-FROM to intercept the control and eval UNWIND-PROTECT cleanup forms.
;;; ecl_frs_pop is emited by the exit manager or the caller. -- jd 2023-11-19
(defmacro with-unwind-frame ((tag) handler-form &body body)
`(with-lexical-scope ()
(let ((*unwind-exit* (list* 'FRAME *unwind-exit*)))
(wt-nl "ecl_frs_push(cl_env_copy," ,tag ");")
(wt-nl "if (__ecl_frs_push_result!=0) {")
,handler-form
,@(when body
`((wt-nl "} else {")
,@body))
(wt-nl "}"))))
(defmacro with-stack-frame ((var &optional loc) &body body)
(ext:with-gensyms (hlp)
`(with-lexical-scope ()
(let* ((,var ,(or loc "_ecl_inner_frame"))
(,hlp "_ecl_inner_frame_aux")
(*unwind-exit* (list* (list 'STACK ,var) *unwind-exit*)))
(wt-nl "struct ecl_stack_frame " ,hlp ";")
(wt-nl *volatile* "cl_object " ,var
"=ecl_stack_frame_open(cl_env_copy,(cl_object)&" ,hlp ",0);")
,@body))))

17
src/cmp/cmpbackend-cxx/cmpc-wt.lsp
View file

@ -110,13 +110,17 @@
;;; LABELS AND JUMPS
;;;
(defun wt-nl-go (label)
(wt-nl-indent)
(wt-go label))
(defun wt-go (label)
(setf (cdr label) t
label (car label))
(wt "goto L" label ";"))
(setf (label-used-p label) t)
(wt "goto L" (label-id label) ";"))
(defun wt-label (label)
(when (cdr label) (wt-nl1 "L" (car label) ":;")))
(when (label-used-p label)
(wt-nl1 "L" (label-id label) ":;")))
;;;
;;; C/C++ COMMENTS
@ -127,7 +131,7 @@
(if single-line
(progn
(fresh-line stream)
(princ "/* " stream))
(princ "/* " stream))
(format stream "~50T/* "))
(let* ((l (1- (length text))))
(declare (fixnum l))
@ -144,8 +148,7 @@
(t
(princ c stream)))))
(princ (schar text l) stream))
(format stream "~70T*/")
)
(format stream "~78T*/"))
(defun do-wt-comment (message-or-format args single-line-p)
(unless (and (symbolp message-or-format) (not (symbol-package message-or-format)))

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

@ -82,17 +82,15 @@
(defun tail-recursion-possible ()
(dolist (ue *unwind-exit*
(baboon :format-control "tail-recursion-possible: should never return."))
(cond ((eq ue 'TAIL-RECURSION-MARK)
(cond ((eq ue *tail-recursion-mark*)
(return t))
((or (numberp ue) (eq ue 'BDS-BIND) (eq ue 'FRAME))
((or (eq ue 'BDS-BIND) (eq ue 'FRAME))
(return nil))
((or (consp ue) (eq ue 'JUMP) (eq ue 'IHS-ENV)))
((or (consp ue) (labelp ue) (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)))
(eq *exit* 'LEAVE))
(defun c2try-tail-recursive-call (fun args)
(when (and *tail-recursion-info*
@ -101,16 +99,12 @@
(tail-recursion-possible)
(inline-possible (fun-name fun))
(= (length args) (length (rest *tail-recursion-info*))))
(let* ((*destination* 'TRASH)
(*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*)))
(c2psetq nil ;; We do not provide any C2FORM
(cdr *tail-recursion-info*) args)
(wt-label *exit*))
(unwind-no-exit 'TAIL-RECURSION-MARK)
(wt-nl "goto TTL;")
(cmpdebug "Tail-recursive call of ~s was replaced by iteration."
(fun-name fun))
(with-exit-label (*exit*)
(let ((*destination* 'TRASH))
;; We do not provide any C2FORM.
(c2psetq nil (cdr *tail-recursion-info*) args)))
(unwind-jump *tail-recursion-mark*)
(cmpdebug "Tail-recursive call of ~s was replaced by iteration." (fun-name fun))
t))
(defun c2call-local (c1form fun args)
@ -137,18 +131,14 @@
(declare (ignore c1form))
(let* ((*temp* *temp*)
(loc (maybe-save-value form args)))
(wt-nl-open-brace)
(wt-nl "struct ecl_stack_frame _ecl_inner_frame_aux;")
(wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open(cl_env_copy,(cl_object)&_ecl_inner_frame_aux,0);")
(let ((*unwind-exit* `((STACK "_ecl_inner_frame") ,@*unwind-exit*)))
(let ((*destination* (if values-p 'values 'return)))
(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(_ecl_inner_frame);")
(wt-nl "ecl_stack_frame_push(_ecl_inner_frame,value0);"))))
(unwind-exit (call-stack-loc nil loc)))
(wt-nl-close-brace)))
(wt-nl "ecl_stack_frame_push_values(" frame ");")
(wt-nl "ecl_stack_frame_push(" frame ",value0);"))))
(unwind-exit (call-stack-loc nil loc)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;

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

@ -23,33 +23,27 @@
(let* ((blk-var (blk-var blk))
(*env-lvl* *env-lvl*))
(check-vref blk-var)
(wt-nl-open-brace)
(when (eq :object (var-kind blk-var))
(setf (var-loc blk-var) (next-lcl))
(wt-nl "cl_object " blk-var ";"))
(when (env-grows (var-ref-ccb blk-var))
;; var is referenced from a closure which may escape.
(let ((env-lvl *env-lvl*))
(wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var)
(wt-nl-open-brace)
(wt-nl "ecl_frs_push(cl_env_copy," blk-var ");")
(wt-nl "if (__ecl_frs_push_result!=0) {")
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*)))
(unwind-exit 'VALUES)
(wt-nl "} else {")
(c2expr body)
(wt "}"))
(wt-nl-close-brace)
(when (var-ref-ccb blk-var) (decf *env*))
(wt-nl-close-brace))
(with-lexical-scope ()
(when (eq :object (var-kind blk-var))
(setf (var-loc blk-var) (next-lcl))
(wt-nl "cl_object " blk-var ";"))
(when (env-grows (var-ref-ccb blk-var))
;; var is referenced from a closure which may escape.
(let ((env-lvl *env-lvl*))
(wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var)
(with-unwind-frame (blk-var)
(unwind-exit 'VALUEZ)
(c2expr body))
(when (var-ref-ccb blk-var)
(decf *env*))))
(c2expr body)))
(defun c2return-from (c1form blk nonlocal val)
(declare (ignore c1form))
(if nonlocal
(progn
(let ((*destination* 'VALUES))
(let ((*destination* 'VALUEZ))
(c2expr* val))
(let ((name (get-object (blk-name blk))))
(wt-nl "cl_return_from(" (blk-var blk) "," name ");")))
@ -66,11 +60,9 @@
(dolist (x body (c2tagbody-body body))
;; Allocate labels.
(when (and (tag-p x) (plusp (tag-ref x)))
(setf (tag-label x) (next-label*))
(setf (tag-unwind-exit x) *unwind-exit*)))
(setf (tag-jump x) (next-label t))))
;; some tag used non locally or inside an unwind-protect
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*))
(*env* *env*) (*env-lvl* *env-lvl*)
(let ((*env* *env*) (*env-lvl* *env-lvl*)
(*lex* *lex*) (*lcl* *lcl*)
(*inline-blocks* 0)
(env-grows (env-grows (var-ref-ccb tag-loc))))
@ -84,54 +76,37 @@
(maybe-open-inline-block)
(wt-nl "cl_object " tag-loc ";"))
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc)
(wt-nl-open-brace)
(wt-nl "ecl_frs_push(cl_env_copy," tag-loc ");")
(wt-nl "if (__ecl_frs_push_result) {")
;; Allocate labels.
(dolist (tag body)
(when (and (tag-p tag) (plusp (tag-ref tag)))
(setf (tag-label tag) (next-label))
(setf (tag-unwind-exit tag) *unwind-exit*)
(wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))")
(wt-go (tag-label tag))))
(when (var-ref-ccb tag-loc)
(wt-nl "ecl_internal_error(\"GO found an inexistent tag\");"))
(wt-nl "}")
(wt-nl-close-brace)
(c2tagbody-body body)
(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))))
(defun c2tagbody-body (body)
;;; INV: BODY is a list of tags and forms. We have processed the body
;;; so that the last element is always a form producing NIL.
(do ((l body (cdr l)))
((null l))
(let* ((this-form (first l)))
(cond ((tag-p this-form)
(wt-label (tag-label this-form)))
((endp (rest l))
;; Last form, it is never a label!
(c2expr this-form))
(t
(let* ((next-form (second l))
(*exit* (if (tag-p next-form)
(tag-label next-form)
(next-label)))
(*unwind-exit* (cons *exit* *unwind-exit*))
(*destination* 'TRASH))
(c2expr this-form)
(unless (tag-p next-form)
(wt-label *exit*))))))))
(loop for (this-form next-form . rest) on body do
(cond ((tag-p this-form)
(wt-label (tag-jump this-form)))
((tag-p next-form)
(with-exit-label (*exit* (tag-jump next-form))
(let ((*destination* 'TRASH))
(c2expr this-form))))
(t
(c2expr this-form)))))
(defun c2go (c1form tag nonlocal)
(declare (ignore c1form))
(if nonlocal
(let ((var (tag-var tag)))
(wt-nl "cl_go(" var ",ecl_make_fixnum(" (tag-index tag) "));"))
;; local go
(progn
(unwind-no-exit-until (tag-unwind-exit tag))
(wt-nl) (wt-go (tag-label tag)))))
(wt-nl "cl_go(" (tag-var tag) ",ecl_make_fixnum(" (tag-index tag) "));")
(unwind-jump (tag-jump tag))))
(defun c2throw (c1form tag val &aux loc)
@ -139,73 +114,53 @@
(case (c1form-name tag)
((VARIABLE LOCATION) (setq loc (c1form-arg 0 tag)))
(t (setq loc (make-temp-var))
(let ((*destination* loc)) (c2expr* tag))))
(let ((*destination* 'VALUES)) (c2expr* val))
(let ((*destination* loc))
(c2expr* tag))))
(let ((*destination* 'VALUEZ))
(c2expr* val))
(wt-nl "cl_throw(" loc ");"))
(defun c2catch (c1form tag body)
(declare (ignore c1form))
(let* ((new-destination (tmp-destination *destination*))
(code (incf *last-label*)))
(code (gensym "CATCH")))
(let ((*destination* 'VALUE0))
(c2expr* tag))
(let* ((*destination* new-destination)
(*unwind-exit* (cons 'FRAME *unwind-exit*)))
(wt-nl-open-brace)
(if (member new-destination '(TRASH VALUES))
(progn
(wt-nl "ecl_frs_push(cl_env_copy," 'VALUE0 ");")
(wt-nl "if (__ecl_frs_push_result==0) {")
(wt-comment "BEGIN CATCH ~A" code)
(with-indentation
(c2expr* body)))
(progn
(wt-nl "ecl_frs_push(cl_env_copy," 'VALUE0 ");")
(wt-nl "if (__ecl_frs_push_result) {")
(wt-comment "BEGIN CATCH ~A" code)
(with-indentation
(with-exit-label (label)
(let ((*exit* label))
(unwind-exit 'VALUES))))
(wt-nl "} else {")
(with-indentation
(c2expr* body)))))
(wt-nl "}")
(wt-nl "ecl_frs_pop(cl_env_copy);")
(wt-comment "END CATCH ~A" code)
(wt-nl-close-brace)
(let ((*destination* new-destination))
(wt-comment "BEGIN CATCH ~A" code)
(with-unwind-frame ('VALUE0)
(unless (member new-destination '(TRASH VALUEZ))
(with-indentation
(with-exit-label (*exit*)
(unwind-exit 'VALUEZ))))
(with-indentation
(c2expr* body)))
(wt-nl "ecl_frs_pop(cl_env_copy);")
(wt-comment "END CATCH ~A" code))
(unwind-exit new-destination)))
(defun c2unwind-protect (c1form form body)
(declare (ignore c1form))
(let* ((sp (make-lcl-var :rep-type :cl-index))
(nargs (make-lcl-var :rep-type :cl-index))
(*unwind-exit* `((STACK ,sp) ,@*unwind-exit*)))
(wt-nl-open-brace)
(with-stack-frame (frame)
;; Here we compile the form which is protected. When this form is aborted,
;; it continues with unwinding=TRUE. We call ecl_frs_pop() manually because
;; we use C2EXPR* in the body.
(wt-nl "volatile bool unwinding = FALSE;")
(wt-nl "cl_index " sp "=ECL_STACK_INDEX(cl_env_copy)," nargs ";")
(wt-nl "ecl_frame_ptr next_fr;")
;; Here we compile the form which is protected. When this form
;; is aborted, it continues at the ecl_frs_pop() with unwinding=TRUE.
(wt-nl "ecl_frs_push(cl_env_copy,ECL_PROTECT_TAG);")
(wt-nl "if (__ecl_frs_push_result) {")
(wt-nl " unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;")
(wt-nl "} else {")
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*))
(*destination* 'VALUES))
(c2expr* form))
(wt-nl "}")
(with-unwind-frame ("ECL_PROTECT_TAG")
(wt-nl " unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;")
(let ((*destination* 'VALUEZ))
(c2expr* form)))
(wt-nl "ecl_frs_pop(cl_env_copy);")
;; Here we save the values of the form which might have been
;; aborted, and execute some cleanup code. This code may also
;; be aborted by some control structure, but is not protected.
(wt-nl nargs "=ecl_stack_push_values(cl_env_copy);")
(wt-nl "ecl_stack_frame_push_values(" frame ");")
(let ((*destination* 'TRASH))
(c2expr* body))
(wt-nl "ecl_stack_pop_values(cl_env_copy," nargs ");")
(wt-nl "ecl_stack_frame_pop_values(" frame ");")
;; Finally, if the protected form was aborted, jump to the
;; next catch point...
(wt-nl "if (unwinding) ecl_unwind(cl_env_copy,next_fr);")
;; ... or simply return the values of the protected form.
(unwind-exit 'VALUES)
(wt-nl-close-brace)))
(unwind-exit 'VALUEZ)))

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

@ -2,14 +2,9 @@
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya
;;;; Copyright (c) 1990, Giuseppe Attardi
;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll
;;;; Copyright (c) 2021, Daniel Kochmański
;;;; Copyright (c) 2023, Daniel Kochmański
;;;;
;;;; 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.
;;;; See the file 'LICENSE' for the copyright details.
;;;;
(in-package #:compiler)
@ -26,30 +21,26 @@
;; other expressions will follow this one. We must thus create
;; a possible label so that the compiled forms exit right at
;; the point where the next form will be compiled.
(with-exit-label (label)
(let* ((*exit* label)
(*unwind-exit* (cons *exit* *unwind-exit*))
;;(*lex* *lex*)
(*lcl* *lcl*)
(*temp* *temp*))
(with-exit-label (*exit*)
(let (;;(*lex* *lex*)
(*lcl* *lcl*)
(*temp* *temp*))
(c2expr form))))
(defun c2progn (c1form forms)
(declare (ignore c1form))
;; c1progn ensures that the length of forms is not less than 1.
(do ((l forms (cdr l))
(lex *lex*))
((endp (cdr l))
(c2expr (car l)))
(let* ((this-form (first l))
(name (c1form-name this-form)))
(let ((*destination* 'TRASH))
(c2expr* (car l)))
(setq *lex* lex) ; recycle lex locations
;; Since PROGN does not have tags, any transfer of control means
;; leaving the current PROGN statement.
(when (or (eq name 'GO) (eq name 'RETURN-FROM))
(return)))))
;; INV C1PROGN ensures that the length of forms is not less than 1.
(loop with lex = *lex*
for (form next . rest) on forms do
(if (null next)
(c2expr form)
(let ((*destination* 'TRASH))
(c2expr* form)
;; recycle lex locations
(setq *lex* lex)))
;; Since PROGN does not have tags, any transfer of control means leaving
;; the current PROGN statement.
until (member (c1form-name form) '(CL:GO CL:RETURN-FROM))))
(defun c2if (c1form fmla form1 form2)
(declare (ignore c1form))
@ -58,7 +49,7 @@
(eq (c1form-name form2) 'LOCATION))
;; Optimize (IF condition true-branch) or a situation in which
;; the false branch can be discarded.
(with-optional-exit-label (false-label)
(with-exit-label (false-label *exit*)
(let ((*destination* `(JUMP-FALSE ,false-label)))
(c2expr* fmla))
(c2expr form1)))
@ -66,7 +57,7 @@
(eq (c1form-name form1) 'LOCATION))
;; Optimize (IF condition useless-value false-branch) when
;; the true branch can be discarded.
(with-optional-exit-label (true-label)
(with-exit-label (true-label *exit*)
(let ((*destination* `(JUMP-TRUE ,true-label)))
(c2expr* fmla))
(c2expr form2)))
@ -77,6 +68,14 @@
(c2expr form1))
(c2expr form2))))
(defun jump-true-destination-p (dest)
(declare (si::c-local))
(and (consp dest) (eq (si:cons-car dest) 'JUMP-TRUE)))
(defun jump-false-destination-p (dest)
(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))
@ -105,19 +104,9 @@
(t
(let ((*inline-blocks* 0)
(*temp* *temp*))
(unwind-exit (negate-argument
(emit-inline-form arg nil)
dest))
(unwind-exit (negate-argument (emit-inline-form arg nil) dest))
(close-inline-blocks))))))
(defun jump-true-destination-p (dest)
(declare (si::c-local))
(and (consp dest) (eq (si:cons-car dest) 'JUMP-TRUE)))
(defun jump-false-destination-p (dest)
(declare (si::c-local))
(and (consp dest) (eq (si:cons-car dest) 'JUMP-FALSE)))
(defun c2fmla-and (c1form butlast last)
(declare (ignore c1form))
(if (jump-false-destination-p *destination*)
@ -148,77 +137,24 @@
(dolist (f butlast)
(let ((*destination* 'VALUE0))
(c2expr* f))
(set-jump-true 'VALUE0 normal-exit))
(wt-nl "if (" 'VALUE0 "!=ECL_NIL) ")
(wt-open-brace) (unwind-jump normal-exit) (wt-nl-close-brace))
(c2expr last))
(unwind-exit 'VALUE0)))))
(defun set-jump-true (loc label)
(multiple-value-bind (constantp value)
(loc-immediate-value-p loc)
(cond ((not constantp)
(cond ((eq (loc-representation-type loc) :bool)
(wt-nl "if (" loc ") {"))
(t
(wt-nl "if ((")
(wt-coerce-loc :object loc)
(wt ")!=ECL_NIL) {")))
(cond ((unwind-no-exit label)
(incf *opened-c-braces*)
(wt-nl) (wt-go label)
(wt-nl-close-brace))
(t
(wt " ") (wt-go label) (wt " }"))))
((null value))
(t
(unwind-no-exit label)
(wt-nl) (wt-go label)))))
(defun set-jump-false (loc label)
(multiple-value-bind (constantp value)
(loc-immediate-value-p loc)
(cond ((not constantp)
(cond ((eq (loc-representation-type loc) :bool)
(wt-nl "if (!(" loc ")) {"))
(t
(wt-nl "if (Null(")
(wt-coerce-loc :object loc)
(wt ")) {")))
(cond ((unwind-no-exit label)
(incf *opened-c-braces*)
(wt-nl) (wt-go label)
(wt-nl-close-brace))
(t
(wt " ") (wt-go label) (wt " }"))))
(value)
(t
(unwind-no-exit label)
(wt-nl) (wt-go label)))))
(defun c2mv-prog1 (c1form form body)
(wt-nl-open-brace)
(wt-nl "struct ecl_stack_frame _ecl_inner_frame_aux;")
(wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open(cl_env_copy,(cl_object)&_ecl_inner_frame_aux,0);")
(let ((*unwind-exit* `((STACK "_ecl_inner_frame") ,@*unwind-exit*)))
(let ((*destination* 'VALUES))
(declare (ignore c1form))
(with-stack-frame (frame)
(let ((*destination* 'VALUEZ))
(c2expr* form))
(wt-nl "ecl_stack_frame_push_values(_ecl_inner_frame);")
(wt-nl "ecl_stack_frame_push_values(" frame ");")
(let ((*destination* 'TRASH))
(mapc #'c2expr* body))
(wt-nl "ecl_stack_frame_pop_values(_ecl_inner_frame);"))
(wt-nl "ecl_stack_frame_close(_ecl_inner_frame);")
(wt-nl-close-brace)
(unwind-exit 'values))
(wt-nl "ecl_stack_frame_pop_values(" frame ");")
(unwind-exit 'VALUEZ)))
(defun c2values (c1form forms)
(declare (ignore c1form))
(when (and (eq *destination* 'RETURN-OBJECT)
(rest forms)
(consp *current-form*)
(eq 'cl:DEFUN (first *current-form*)))
(cmpwarn "Trying to return multiple values. ~
~%;But ~a was proclaimed to have single value.~
~%;Only first one will be assured."
(second *current-form*)))
(cond
;; When the values are not going to be used, then just
;; process each form separately.
@ -227,25 +163,25 @@
;; 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.
;; 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* 'RETURN)
(cond ((eq *destination* 'LEAVE)
(wt-nl "value0 = ECL_NIL;")
(wt-nl "cl_env_copy->nvalues = 0;")
(unwind-exit 'RETURN))
((eq *destination* 'VALUES)
(unwind-exit 'LEAVE))
((eq *destination* 'VALUEZ)
(wt-nl "cl_env_copy->values[0] = ECL_NIL;")
(wt-nl "cl_env_copy->nvalues = 0;")
(unwind-exit 'VALUES))
(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* '(RETURN VALUES)))
(if (or (not (member *destination* '(LEAVE VALUEZ)))
(c1form-single-valued-p form))
(c2expr form)
(progn
@ -266,5 +202,5 @@
((null vl))
(declare (fixnum i))
(wt-nl "cl_env_copy->values[" i "] = " (first vl) ";"))
(unwind-exit 'VALUES)
(unwind-exit 'VALUEZ)
(close-inline-blocks)))))

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

@ -4,203 +4,198 @@
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; Copyright (c) 2023, Daniel Kochmański.
;;;;
;;;; 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 the file 'LICENSE' for the copyright details.
;;;;
;;;; See file '../Copyright' for full details.
;;;; CMPEXIT Exit manager.
;;;;
;;;; 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.
;;;;
(in-package "COMPILER")
(defun unwind-exit (loc)
(flet ((unwind-cond-p ()
(and (consp *destination*)
(member (si:cons-car *destination*) '(JUMP-FALSE JUMP-TRUE))))
(unwind-jump-p ()
(labelp *exit*))
(unwind-exit-p ()
(eq *exit* 'LEAVE)))
(cond ((unwind-cond-p) (unwind-cjump loc))
((unwind-jump-p) (unwind-label loc))
((unwind-exit-p) (unwind-leave loc))
(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)))
;;;
(defun baboon-exit-not-found (exit)
(baboon :format-control "The value of exit~%~A~%is not found in *UNWIND-EXIT*~%~A"
:format-arguments (list exit *unwind-exit*)))
(defun baboon-exit-invalid (exit)
(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-exit (exit)
(baboon :format-control "The value of exit~%~A~%found in *UNWIND-EXIT*~%~A~%is not valid."
:format-arguments (list exit *unwind-exit*)))
(defun destination-value-matters-p (dest)
(declare (si::c-local))
(if (atom dest)
(not (eq dest 'TRASH))
(not (member (car dest) '(JUMP-FALSE JUMP-TRUE)))))
;;; UNWIND-EXIT TAGS PURPOSE
;;;
;;; number -> unknown purpose
;;; JUMP -> unknown purpose
;;; FRAME -> ecl_frs_push()
;;; (STACK frame) -> ecl_stack_frame_open(env, frame, initial_size)
;;; IHS -> ihs push
;;; IHS-ENV -> ihs push
;;; BDS-BIND -> binding of 1 special variable
;;; (number . {T|NIL}) -> label
;;; (LCL n) -> n local variables
;;; (STACK n) -> n elements pushed in stack
;;; TAIL-RECURSION-MARK -> TTL: label created
;;; RETURN* -> outermost location
;;;
;;; (*) also RETURN-FIXNUM, -CHARACTER, -SINGLE-FLOAT
;;; -DOUBLE-FLOAT, -OBJECT.
;;;
(defun unwind-bds (bds-lcl bds-bind stack-frame ihs-p)
(declare (fixnum bds-bind))
(let ((some nil))
(when stack-frame
(setf some t)
(if (stringp stack-frame)
(wt-nl "ecl_stack_frame_close(" stack-frame ");")
(wt-nl "ECL_STACK_SET_INDEX(cl_env_copy," stack-frame ");")))
(when bds-lcl
(setf some t)
(wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");"))
(cond ((< bds-bind 4)
(dotimes (n bds-bind)
(declare (fixnum n))
(setf some t)
(wt-nl "ecl_bds_unwind1(cl_env_copy);")))
(t
(setf some t)
(wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");")))
(case ihs-p
(IHS
(setf some t)
(wt-nl "ecl_ihs_pop(cl_env_copy);"))
(IHS-ENV
(setf some t)
(wt-nl "ihs.lex_env = _ecl_debug_env;")))
some))
;;; (LCL n) -> binding stack pointer to Nth local variable
;;; LEAVE -> outermost location
;;; #<label id used-p> -> label (basic block leader)
(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil))
(declare (fixnum bds-bind))
(when (consp *destination*)
(case (car *destination*)
(JUMP-TRUE
(set-jump-true loc (second *destination*))
(when (eq loc *vv-t*)
(return-from unwind-exit)))
(JUMP-FALSE
(set-jump-false loc (second *destination*))
(when (eq loc *vv-nil*)
(return-from unwind-exit)))))
(dolist (ue *unwind-exit* (baboon-improper-*exit*))
;; perform all unwind-exit's which precede *exit*
(cond
((consp ue) ; ( label# . ref-flag )| (STACK n) |(LCL n)
(cond ((eq (car ue) 'STACK)
(setf stack-frame (second ue)))
((eq (car ue) 'LCL)
(setq bds-lcl ue bds-bind 0))
((eq ue *exit*)
;; all body forms except the last (returning) are dealt here
(cond ((and (consp *destination*)
(or (eq (car *destination*) 'JUMP-TRUE)
(eq (car *destination*) 'JUMP-FALSE)))
(unwind-bds bds-lcl bds-bind stack-frame ihs-p))
((not (or bds-lcl (plusp bds-bind) stack-frame))
(set-loc loc))
;; Save the value if LOC may possibly refer
;; to special binding.
((or (loc-refers-to-special-p loc)
(loc-refers-to-special-p *destination*))
(let* ((*temp* *temp*)
(temp (make-temp-var)))
(let ((*destination* temp))
(set-loc loc)) ; temp <- loc
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(set-loc temp))) ; *destination* <- temp
(t
(set-loc loc)
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)))
(when jump-p (wt-nl) (wt-go *exit*))
(return))
(t (setq jump-p t))))
((numberp ue)
(baboon-unwind-exit ue)
(setq bds-lcl ue bds-bind 0))
(t (case ue
(IHS (setf ihs-p ue))
(IHS-ENV (setf ihs-p (or ihs-p ue)))
(BDS-BIND (incf bds-bind))
(RETURN
(unless (eq *exit* 'RETURN) (baboon-unwind-exit ue))
;; *destination* must be either RETURN or TRASH.
(cond ((eq loc 'VALUES)
;; from multiple-value-prog1 or values
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return cl_env_copy->values[0];"))
((eq loc 'RETURN)
;; from multiple-value-prog1 or values
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return value0;"))
(t
(let* ((*destination* 'RETURN))
(set-loc loc))
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return value0;")))
(return))
((RETURN-FIXNUM RETURN-CHARACTER RETURN-OBJECT
RETURN-DOUBLE-FLOAT RETURN-SINGLE-FLOAT RETURN-LONG-FLOAT
RETURN-CSFLOAT RETURN-CSFLOAT RETURN-CSFLOAT)
(when (eq *exit* ue)
;; *destination* must be RETURN-FIXNUM
(setq loc (list 'COERCE-LOC
(getf '(RETURN-FIXNUM :fixnum
RETURN-CHARACTER :char
RETURN-SINGLE-FLOAT :float
RETURN-DOUBLE-FLOAT :double
RETURN-CSFLOAT :csfloat
RETURN-CDFLOAT :cdfloat
RETURN-CLFLOAT :clfloat
RETURN-OBJECT :object)
ue)
loc))
(if (or bds-lcl (plusp bds-bind))
(let ((lcl (make-lcl-var :type (second loc))))
(wt-nl-open-brace)
(wt-nl "cl_fixnum " lcl "= " loc ";")
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return(" lcl ");")
(wt-nl-close-brace))
(progn
(wt-nl "return(" loc ");")))
(return)))
(FRAME
(let ((*destination* (tmp-destination *destination*)))
(set-loc loc)
(setq loc *destination*))
(wt-nl "ecl_frs_pop(cl_env_copy);"))
(TAIL-RECURSION-MARK)
(JUMP (setq jump-p t))
(t (baboon-unwind-exit ue))))))
;;; Never reached
)
(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 baboon-improper-*exit* ()
(baboon :format-control "The value of *EXIT*~%~A~%is not found in *UNWIND-EXIT*~%~A"
:format-arguments (list *exit* *unwind-exit*)))
(defun baboon-unwind-exit (ue)
(baboon :format-control "The value of unwind exit~%~A~%found in *UNWIND-EXIT*~%~A~%is not valid."
:format-arguments (list ue *unwind-exit*)))
(defun unwind-no-exit-until (last-cons)
(defun compute-unwind (last-cons)
(declare (si::c-local))
(loop with bds-lcl = nil
with bds-bind = 0
with stack-frame = nil
with ihs-p = nil
for unwind-exit on *unwind-exit*
for ue = (car unwind-exit)
until (eq unwind-exit last-cons)
do (cond
((consp ue)
(when (eq (first ue) 'STACK)
(setf stack-frame (second ue))))
((numberp ue)
(setq bds-lcl ue bds-bind 0))
((eq ue 'BDS-BIND)
(incf bds-bind))
((eq ue 'FRAME)
(wt-nl "ecl_frs_pop(cl_env_copy);"))
((eq ue 'JUMP))
((eq ue 'IHS-ENV)
(setf ihs-p ue))
(t (baboon-unwind-exit ue)))
finally (return (unwind-bds bds-lcl bds-bind stack-frame ihs-p))))
with bds-bind = 0
with stack-frame = nil
with ihs-p = nil
with frs-bind = 0
with jump-p = nil
with exit-p = nil
for unwind-exit on *unwind-exit*
for ue = (car unwind-exit)
until (eq unwind-exit last-cons)
do (cond
((consp ue)
(case (first ue)
(STACK (setq stack-frame (second ue)))
(LCL (setq bds-lcl ue bds-bind 0))
(otherwise (baboon-unwind-exit ue))))
((labelp ue)
(setf jump-p t))
((eq ue 'BDS-BIND)
(incf bds-bind))
((eq ue 'FRAME)
(incf frs-bind))
((eq ue 'IHS)
(setf ihs-p ue))
((eq ue 'IHS-ENV)
(setf ihs-p (or ihs-p ue)))
((eq ue 'LEAVE)
(setf exit-p t))
(t (baboon-unwind-exit ue)))
finally (return (values frs-bind bds-lcl bds-bind stack-frame ihs-p jump-p exit-p))))
(defun unwind-no-exit (exit)
(let ((where (member exit *unwind-exit* :test #'eq)))
(unless where
(baboon :format-control "Unwind-exit label ~A not found"
:format-arguments (list exit)))
(unwind-no-exit-until where)))
(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;")))))
(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*))))
;;; 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
(defun unwind-cjump (loc)
(declare (si::c-local))
(multiple-value-bind (constantp value) (loc-immediate-value-p loc)
(destructuring-bind (target label) *destination*
(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))
((not (null value))
(unwind-jump label)))
(unless (and constantp (not (null value)))
(let ((*destination* 'TRASH))
(unwind-exit *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))
((null value)
(unwind-jump label)))
(unless (and constantp (null value))
(let ((*destination* 'TRASH))
(unwind-exit *vv-t*))))))))

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

@ -57,7 +57,7 @@
)
(t
(c2expr* form)))
finally (unwind-exit nil)))
finally (unwind-exit *vv-nil*)))
(defun c2c-inline (c1form arguments &rest rest)
(declare (ignore c1form))
@ -72,6 +72,8 @@
(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 ")
@ -80,30 +82,28 @@
(wt-nl-h "static " return-type-name " " fmod c-name "(")
(wt-nl1 "static " return-type-name " " fmod c-name "(")
(loop with comma = ""
for n from 0
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" n)
(wt comma arg-type-name " var" n)
do (wt-h comma arg-type-name " " var)
(wt comma arg-type-name " " var)
(setf comma ","))
(wt ")")
(wt-h ");")
(wt-nl-open-brace)
(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;")
(wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, frame, helper)")
(loop for n from 0
and type in arg-types
and ct in arg-type-constants
do (wt-nl "ecl_stack_frame_push("
"frame,ecl_foreign_data_ref_elt(" "&var" n "," ct ")"
");"))
(wt-nl "aux = ecl_apply_from_stack_frame(frame,"
"ecl_fdefinition(" c-name-constant "));")
(wt-nl "ecl_stack_frame_close(frame);")
(when return-p
(wt-nl "ecl_foreign_data_set_elt(&output," return-type-code ",aux);")
(wt-nl "return output;"))
(wt-nl-close-brace)))
(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;")))))

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

@ -16,47 +16,45 @@
(defun c2locals (c1form funs body labels ;; labels is T when deriving from labels
&aux
(*env* *env*)
(*inline-blocks* 0)
(*env-lvl* *env-lvl*))
(*env* *env*)
(*inline-blocks* 0)
(*env-lvl* *env-lvl*))
(declare (ignore c1form labels))
;; create location for each function which is returned,
;; either in lexical:
;; create location for each function which is returned, either in lexical:
(loop with env-grows = nil
with closed-vars = '()
for fun in funs
for var = (fun-var fun)
when (plusp (var-ref var))
do (case (var-kind var)
((lexical closure)
(push var closed-vars)
(unless env-grows
(setq env-grows (var-ref-ccb var))))
(otherwise
(maybe-open-inline-block)
(bind (next-lcl) var)
(wt-nl "cl_object " *volatile* var ";")))
finally
;; if we have closed variables
(when (env-grows env-grows)
(maybe-open-inline-block)
(let ((env-lvl *env-lvl*))
(wt "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
;; bind closed locations because of possible circularities
(loop for var in closed-vars
do (bind *vv-nil* var)))
with closed-vars = '()
for fun in funs
for var = (fun-var fun)
when (plusp (var-ref var))
do (case (var-kind var)
((lexical closure)
(push var closed-vars)
(unless env-grows
(setq env-grows (var-ref-ccb var))))
(otherwise
(maybe-open-inline-block)
(bind (next-lcl) var)
(wt-nl "cl_object " *volatile* var ";")))
finally
;; if we have closed variables
(when (env-grows env-grows)
(maybe-open-inline-block)
(let ((env-lvl *env-lvl*))
(wt "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
;; bind closed locations because of possible circularities
(loop for var in closed-vars
do (bind *vv-nil* var)))
;; create the functions:
(mapc #'new-local funs)
(map nil #'update-function-env funs)
;; - then assign to it
(loop for fun in funs
for var = (fun-var fun)
when (plusp (var-ref var))
do (set-var (list 'MAKE-CCLOSURE fun) var))
for var = (fun-var fun)
when (plusp (var-ref var))
do (set-var (list 'MAKE-CCLOSURE fun) var))
(c2expr body)
(close-inline-blocks))
;;; Mechanism for sharing code.
(defun new-local (fun)
(defun update-function-env (fun)
(declare (type fun fun))
(case (fun-closure fun)
(CLOSURE
@ -71,7 +69,7 @@
(otherwise
(setf (fun-level fun) 0
(fun-env fun) 0)))
(push fun *local-funs*))
(register-function fun))
#| Steps:
1. defun creates declarations for requireds + va_alist
@ -214,27 +212,26 @@
;; which is what we do here.
(let ((va-arg-loc (if simple-varargs 'VA-ARG 'CL-VA-ARG)))
;; counter for optionals
(wt-nl-open-brace)
(wt-nl "int i = " nreq ";")
(do ((opt optionals (cdddr opt))
(type-check optional-type-check-forms (cdr type-check)))
((endp opt))
(wt-nl "if (i >= narg) {")
(let ((*opened-c-braces* (1+ *opened-c-braces*)))
(bind-init (second opt) (first opt))
(when (third opt)
(bind *vv-nil* (third opt))))
(wt-nl "} else {")
(let ((*opened-c-braces* (1+ *opened-c-braces*))
(*unwind-exit* *unwind-exit*))
(wt-nl "i++;")
(bind va-arg-loc (first opt))
(if (car type-check)
(c2expr* (car type-check)))
(when (third opt)
(bind *vv-t* (third opt))))
(wt-nl "}"))
(wt-nl-close-brace)))
(with-lexical-scope ()
(wt-nl "int i = " nreq ";")
(do ((opt optionals (cdddr opt))
(type-check optional-type-check-forms (cdr type-check)))
((endp opt))
(wt-nl "if (i >= narg) {")
(let ((*opened-c-braces* (1+ *opened-c-braces*)))
(bind-init (second opt) (first opt))
(when (third opt)
(bind *vv-nil* (third opt))))
(wt-nl "} else {")
(let ((*opened-c-braces* (1+ *opened-c-braces*))
(*unwind-exit* *unwind-exit*))
(wt-nl "i++;")
(bind va-arg-loc (first opt))
(if (car type-check)
(c2expr* (car type-check)))
(when (third opt)
(bind *vv-t* (third opt))))
(wt-nl "}")))))
(when (or rest key-flag allow-other-keys)
(cond ((not (or key-flag allow-other-keys))
@ -295,14 +292,12 @@
(when flag
(setf (second KEYVARS[i]) (+ nkey i))
(bind KEYVARS[i] flag))))
(when *tail-recursion-info*
(push 'TAIL-RECURSION-MARK *unwind-exit*)
(wt-nl1 "TTL:"))
(setf *tail-recursion-mark* (next-label t))
(push *tail-recursion-mark* *unwind-exit*)
(wt-label *tail-recursion-mark*))
;;; Now the parameters are ready, after all!
(c2expr body)
(close-inline-blocks))
(defun wt-maybe-check-num-arguments (use-narg minarg maxarg fname)

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

@ -37,22 +37,6 @@
(t
(unknown-location 'wt-loc loc))))
(defun wt-lcl (lcl)
(unless (numberp lcl)
(baboon :format-control "wt-lcl: ~s NaN"
:format-arguments (list lcl)))
(wt "v" lcl))
(defun wt-lcl-loc (lcl &optional type name)
(declare (ignore type))
(unless (numberp lcl)
(baboon :format-control "wt-lcl-loc: ~s NaN"
:format-arguments (list lcl)))
(wt "v" lcl name))
(defun wt-temp (temp)
(wt "T" temp))
(defun wt-fixnum (value &optional vv)
(declare (ignore vv))
(princ value *compiler-output1*)
@ -178,13 +162,13 @@
(wt "(" vv "->symbol.gfdef)")))
(t
;; #'(SETF symbol)
(let ((set-loc (assoc name *setf-definitions*)))
(unless set-loc
(let ((setf-loc (assoc name *setf-definitions*)))
(unless setf-loc
(let* ((setf-vv (data-empty-loc*))
(name-vv (get-object name)))
(setf set-loc (list name setf-vv name-vv))
(push set-loc *setf-definitions*)))
(wt "ECL_CONS_CAR(" (second set-loc) ")"))))))
(setf setf-loc (list name setf-vv name-vv))
(push setf-loc *setf-definitions*)))
(wt "ECL_CONS_CAR(" (second setf-loc) ")"))))))
(defun environment-accessor (fun)
(let* ((env-var (env-var-name *env-lvl*))
@ -369,7 +353,7 @@
(case c
(#\@
(let ((object (read s)))
(unless (and (consp object) (eq (car object) 'RETURN))
(unless (and (consp object) (eq (car object) 'CL:RETURN))
(cmperr "Used @~s in C-INLINE form. Expected syntax is @(RETURN ...)." object))
(if (eq output-vars 'VALUES)
(cmperr "Used @(RETURN ...) in a C-INLINE form with no output values.")
@ -399,61 +383,66 @@
;;; SET-LOC
;;;
(defun set-unknown-loc (loc)
(declare (ignore loc))
(unknown-location 'set-loc *destination*))
(defun set-unknown-loc (destination loc)
(unknown-location 'set-loc destination))
(defun set-loc (loc &aux fd)
(let ((destination *destination*))
(cond ((eq destination loc))
((symbolp destination)
(funcall (gethash destination *set-loc-dispatch-table*
'set-unknown-loc)
loc))
((var-p destination)
(set-var loc destination))
((vv-p destination)
(set-vv loc destination))
((atom destination)
(unknown-location 'set-loc destination))
(t
(let ((fd (gethash (first destination) *set-loc-dispatch-table*)))
(if fd
(apply fd loc (rest destination))
(progn
(wt-nl)
(wt-loc destination) (wt " = ")
(wt-coerce-loc (loc-representation-type *destination*) loc)
(wt ";"))))))))
(defun set-loc (destination loc &aux fd)
(cond ((eq destination loc))
((symbolp destination)
(funcall (gethash destination *set-loc-dispatch-table* 'set-unknown-loc)
loc))
((var-p destination)
(set-var loc destination))
((vv-p destination)
(set-vv loc destination))
((atom destination)
(unknown-location 'set-loc destination loc))
(t
(ext:if-let ((fd (gethash (first destination) *set-loc-dispatch-table*)))
(apply fd loc (rest destination))
(progn
(wt-nl)
(wt-loc destination) (wt " = ")
(wt-coerce-loc (loc-representation-type *destination*) loc)
(wt ";"))))))
(defun set-the-loc (loc type orig-loc)
(declare (ignore type))
(let ((*destination* orig-loc))
(set-loc loc)))
(set-loc orig-loc loc))
(defun set-values-loc (loc)
(cond ((eq loc 'VALUES))
(defun set-valuez-loc (loc)
(cond ((eq loc 'VALUEZ))
((uses-values loc)
(wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc) (wt ";"))
(t
(wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc)
(wt ";")
(wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc) (wt ";")
(wt-nl "cl_env_copy->nvalues = 1;"))))
(defun set-value0-loc (loc)
(wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";"))
(defun set-return-loc (loc)
(cond ((or (eq loc 'VALUES) (uses-values loc))
(defun set-leave-loc (loc)
(cond ((or (eq loc 'VALUEZ) (uses-values loc))
(wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";"))
((eq loc 'VALUE0)
(wt-nl "cl_env_copy->nvalues = 1;"))
((eq loc 'RETURN))
((eq loc 'LEAVE))
(t
(wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";")
(wt-nl "cl_env_copy->nvalues = 1;"))))
(defun set-trash-loc (loc)
(defun set-trash-loc (loc &rest args)
(declare (ignore args))
(when (loc-with-side-effects-p loc)
(wt-nl loc ";")
t))
;;;
;;; Foreign data
;;;
(defun wt-ffi-data-ref (data ffi-tag)
(wt "ecl_foreign_data_ref_elt(&" data "," ffi-tag ")"))
(defun wt-ffi-data-set (value data ffi-tag)
(wt "ecl_foreign_data_set_elt(&" data "," ffi-tag "," value ");"))

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

@ -1,62 +1,68 @@
(in-package #:compiler)
(defun wt-print-header (source)
(wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version))
#-ecl-min
(multiple-value-bind (second minute hour day month year)
(get-decoded-time)
(declare (ignore second))
(wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute)
(wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type)))
(wt-comment-nl "Source: ~A" source))
(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source)
(with-cxx-env ()
;; After this step we still can add new objects, but objects that are
;; already stored in VV or VVtemp must not change the location.
(optimize-cxx-data *referenced-objects*)
(setq *compiler-phase* 't2)
(with-open-file (*compiler-output1* c-pathname :direction :output
:if-does-not-exist :create
:if-exists :supersede)
(with-open-file (*compiler-output2* h-pathname :direction :output
:if-does-not-exist :create
:if-exists :supersede)
(wt-print-header source)
(wt-nl1 "#include " *cmpinclude*)
(ctop-write init-name h-pathname data-pathname)
(terpri *compiler-output1*)
(terpri *compiler-output2*)))
(data-c-dump data-pathname)))
;;;; CMPTOP -- Compiler top-level.
(defun t2expr (form)
(when form
(ext:if-let ((def (gethash (c1form-name form) *t2-dispatch-table*)))
(let ((*compile-file-truename* (c1form-file form))
(*compile-file-position* (c1form-file-position form))
(*current-toplevel-form* (c1form-form form))
(*current-form* (c1form-form form))
(*cmp-env* (c1form-env form)))
(apply def form (c1form-args form)))
(cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form))))
(check-type form c1form)
(ext:if-let ((def (gethash (c1form-name form) *t2-dispatch-table*)))
(let ((*compile-file-truename* (c1form-file form))
(*compile-file-position* (c1form-file-position form))
(*current-toplevel-form* (c1form-form form))
(*current-form* (c1form-form form))
(*cmp-env* (c1form-env form)))
(apply def form (c1form-args form)))
(cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form)))
(defun emit-local-funs ()
(defun emit-functions (*compiler-output1*)
(declare (si::c-local))
;; Local functions and closure functions
(do ((*compile-time-too* nil)
(*compile-toplevel* nil))
;; repeat until t3local-fun generates no more
((eq *emitted-local-funs* *local-funs*))
;; scan *local-funs* backwards
(do ((lfs *local-funs* (cdr lfs)))
((eq (cdr lfs) *emitted-local-funs*)
(setq *emitted-local-funs* lfs)
(locally (declare (notinline t3local-fun))
(*compile-toplevel* nil)
(*emitted-functions* nil))
;; repeat until t3function generates no more
((eq *emitted-functions* *functions*))
;; scan *functions* backwards
(do ((lfs *functions* (cdr lfs)))
((eq (cdr lfs) *emitted-functions*)
(setq *emitted-functions* lfs)
(locally (declare (notinline t3function))
;; so disassemble can redefine it
(t3local-fun (first lfs)))))))
(t3function (first lfs)))))))
(defun ctop-write (name h-pathname data-pathname
&aux def top-output-string
(*volatile* "volatile "))
(wt-nl "#include \"" (brief-namestring h-pathname) "\"")
;; VV might be needed by functions in CLINES.
(wt-nl-h "#ifdef ECL_DYNAMIC_VV")
(wt-nl-h "static cl_object *VV;")
(wt-nl-h "#else")
(wt-nl-h "static cl_object VV[VM];")
(wt-nl-h "#endif")
(output-clines *compiler-output2*)
(wt-nl-h "#ifdef __cplusplus")
(wt-nl-h "extern \"C\" {")
(wt-nl-h "#endif")
;;; Initialization function.
(defun emit-entry-fun (name *compiler-output1*)
(let* ((*opened-c-braces* 0)
(*aux-closure* nil)
(c-output-file *compiler-output1*)
(*compiler-output1* (make-string-output-stream))
(*emitted-local-funs* nil)
(*compiler-declared-globals* (make-hash-table)))
(wt-nl "#include \"" (brief-namestring data-pathname) "\"")
(wt-nl "#ifdef __cplusplus")
(wt-nl "extern \"C\"")
(wt-nl "#endif")
(*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();")
@ -85,19 +91,37 @@
;; 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 c-output-file))
(emit-toplevel-form form))
(dolist (form *top-level-forms*)
(emit-toplevel-form form c-output-file))
(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)))
(wt-nl-close-many-braces 0)
(setq top-output-string (get-output-stream-string *compiler-output1*)))
(defun ctop-write (init-name h-pathname data-pathname
&aux def top-output-string (*volatile* "volatile "))
(wt-nl "#include \"" (brief-namestring h-pathname) "\"")
;; VV might be needed by functions in CLINES.
(wt-nl-h "#ifdef ECL_DYNAMIC_VV")
(wt-nl-h "static cl_object *VV;")
(wt-nl-h "#else")
(wt-nl-h "static cl_object VV[VM];")
(wt-nl-h "#endif")
(output-clines *compiler-output2*)
(wt-nl-h "#ifdef __cplusplus")
(wt-nl-h "extern \"C\" {")
(wt-nl-h "#endif")
;;; 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)
(emit-functions *compiler-output1*)
(setq top-output-string (get-output-stream-string output)))
;; Declarations in h-file.
(wt-nl-h "static cl_object Cblock;")
(let ((num-objects (data-size)))
@ -114,7 +138,7 @@
(wt-nl-h "#define ECL_DEFINE_SETF_FUNCTIONS ")
(loop for (name setf-vv name-vv) in *setf-definitions*
do (wt-h #\\ #\Newline setf-vv "=ecl_setf_definition(" name-vv ",ECL_T);"))
do (wt-h #\\ #\Newline setf-vv "=ecl_setf_definition(" name-vv ",ECL_T);"))
(wt-nl-h "#ifdef __cplusplus")
(wt-nl-h "}")
@ -138,9 +162,13 @@
(dolist (x *callbacks*)
(apply #'t3-defcallback x)))
(wt-nl "#include \"" (brief-namestring data-pathname) "\"")
(wt-nl "#ifdef __cplusplus")
(wt-nl "extern \"C\"")
(wt-nl "#endif")
(wt-nl top-output-string))
(defun emit-toplevel-form (form c-output-file)
(defun emit-toplevel-form (form)
(declare (si::c-local))
(let ((*ihs-used-p* nil)
(*max-lex* 0)
@ -164,14 +192,10 @@
(plusp *max-temp*)
(plusp *max-env*)
*ihs-used-p*)
(progn
(wt-nl-open-brace)
(with-lexical-scope ()
(wt-function-locals)
(write-sequence body *compiler-output1*)
(wt-nl-close-brace))
(write-sequence body *compiler-output1*)))
(let ((*compiler-output1* c-output-file))
(emit-local-funs))))
(write-sequence body *compiler-output1*))
(write-sequence body *compiler-output1*)))))
(defun t2compiler-let (c1form symbols values body)
(declare (ignore c1form))
@ -218,99 +242,34 @@
(defun t2ordinary (c1form form)
(declare (ignore c1form))
(let* ((*exit* (next-label))
(*unwind-exit* (list *exit*))
(*destination* 'TRASH))
(c2expr form)
(wt-label *exit*)))
(with-exit-label (*exit*)
(let ((*destination* 'TRASH))
(c2expr form))))
(defun t2load-time-value (c1form vv-loc form)
(declare (ignore c1form))
(let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
(*destination* vv-loc))
(c2expr form)
(wt-label *exit*)))
(with-exit-label (*exit*)
(let ((*destination* vv-loc))
(c2expr form))))
(defun t2make-form (c1form vv-loc form)
(declare (ignore c1form))
(let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
(*destination* vv-loc))
(c2expr form)
(wt-label *exit*)))
(with-exit-label (*exit*)
(let ((*destination* vv-loc))
(c2expr form))))
(defun t2init-form (c1form vv-loc form)
(declare (ignore c1form vv-loc))
(let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
(*destination* 'TRASH))
(c2expr form)
(wt-label *exit*)))
(with-exit-label (*exit*)
(let ((*destination* 'TRASH))
(c2expr form))))
(defun locative-type-from-var-kind (kind)
(cdr (assoc kind
'((:object . "_ecl_object_loc")
(:fixnum . "_ecl_fixnum_loc")
(:char . "_ecl_base_char_loc")
(:float . "_ecl_float_loc")
(:double . "_ecl_double_loc")
(:long-double . "_ecl_long_double_loc")
#+complex-float (:csfloat . "_ecl_csfloat_loc")
#+complex-float (:cdfloat . "_ecl_cdfloat_loc")
#+complex-float (:clfloat . "_ecl_clfloat_loc")
#+sse2 (:int-sse-pack . "_ecl_int_sse_pack_loc")
#+sse2 (:float-sse-pack . "_ecl_float_sse_pack_loc")
#+sse2 (:double-sse-pack . "_ecl_double_sse_pack_loc")
((special global closure lexical) . NIL)))))
(defun build-debug-lexical-env (var-locations &optional first)
#-:msvc ;; FIXME! Problem with initialization of statically defined vectors
(let* ((filtered-locations '())
(filtered-codes '()))
;; Filter out variables that we know how to store in the
;; debug information table. This excludes among other things
;; closures and special variables.
(loop for var in var-locations
for name = (let ((*package* (find-package "KEYWORD")))
(format nil "\"~S\"" (var-name var)))
for code = (locative-type-from-var-kind (var-kind var))
for loc = (var-loc var)
when (and code (consp loc) (eq (first loc) 'LCL))
do (progn
(push (cons name code) filtered-codes)
(push loc filtered-locations)))
;; Generate two tables, a static one with information about the
;; variables, including name and type, and dynamic one, which is
;; a vector of pointer to the variables.
(when filtered-codes
(setf *ihs-used-p* t)
(wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={")
(loop for (name . code) in filtered-codes
for i from 0
do (wt-nl (if (zerop i) "{" ",{") name "," code "}"))
(wt "};")
(wt-nl "const cl_index _ecl_debug_info_raw[]={")
(wt-nl (if first "(cl_index)(ECL_NIL)," "(cl_index)(_ecl_debug_env),")
"(cl_index)(_ecl_descriptors)")
(loop for var-loc in filtered-locations
do (wt ",(cl_index)(&" var-loc ")"))
(wt "};")
(wt-nl "ecl_def_ct_vector(_ecl_debug_env,ecl_aet_index,_ecl_debug_info_raw,"
(+ 2 (length filtered-locations))
",,);")
(unless first
(wt-nl "ihs.lex_env = _ecl_debug_env;")))
filtered-codes))
(defun pop-debug-lexical-env ()
(wt-nl "ihs.lex_env = _ecl_debug_env;"))
(defun t3local-fun (fun)
(defun t3function (fun)
(declare (type fun fun))
;; Compiler note about compiling this function
(when *compile-print*
(ext:when-let ((name (or (fun-name fun) (fun-description fun))))
(format t "~&;;; Emitting code for ~s.~%" name)))
(let* ((lambda-expr (fun-lambda fun))
(*cmp-env* (c1form-env lambda-expr))
(*lcl* 0) (*temp* 0) (*max-temp* 0)
@ -320,33 +279,33 @@
(*max-env* *env*) (*env-lvl* 0)
(*aux-closure* nil)
(*level* (fun-lexical-levels fun))
(*exit* 'RETURN)
(*unwind-exit* '(RETURN))
(*destination* 'RETURN)
(*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)))
;; Function declaration. Returns NIL if this function needs no body.
(when (t3local-fun-declaration fun)
(wt-nl-open-brace)
(let ((body (t3local-fun-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)
(t3local-fun-closure-scan fun))
(write-sequence body *compiler-output1*)
(wt-nl-close-many-braces 0)))))
(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 t3local-fun-body (fun)
(defun t3function-body (fun)
(let ((string (make-array 2048 :element-type 'character
:adjustable t
:fill-pointer 0)))
:adjustable t
:fill-pointer 0)))
(with-output-to-string (*compiler-output1* string)
(let ((lambda-expr (fun-lambda fun)))
(c2lambda-expr (c1form-arg 0 lambda-expr)
@ -361,23 +320,20 @@
(fun-keyword-type-check-forms fun))))
string))
(defun t3local-fun-declaration (fun)
(defun t3function-declaration (fun)
(declare (type fun fun))
(wt-comment-nl (cond ((fun-global fun) "function definition for ~a")
((eq (fun-closure fun) 'CLOSURE) "closure ~a")
(t "local function ~a"))
(or (fun-name fun) (fun-description fun) 'CLOSURE))
(when (fun-shares-with fun)
(wt-comment-nl "... shares definition with ~a" (fun-name (fun-shares-with fun)))
(return-from t3local-fun-declaration nil))
(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
for arg in (car lambda-list)
collect (next-lcl (var-name arg))))
repeat si::c-arguments-limit
for arg in (car lambda-list)
collect (next-lcl (var-name arg))))
(narg (fun-needs-narg fun)))
(let ((cmp-env (c1form-env lambda-expr)))
(wt-comment-nl "optimize speed ~D, debug ~D, space ~D, safety ~D "
@ -401,15 +357,14 @@
(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)
(setf comma ", "))
do (wt-h comma "cl_object " volatile)
(wt comma "cl_object " volatile lcl)
(setf comma ", "))
(when narg
(wt-h ", ...")
(wt ", ..."))
(wt-h ");")
(wt ")"))
t)
(wt ")")))
(defun fun-closure-variables (fun)
(sort (remove-if
@ -434,7 +389,7 @@
(fun-level fun)
0))
(defun t3local-fun-closure-scan (fun)
(defun t3function-closure-scan (fun)
(let ((clv-used (fun-closure-variables fun)))
(wt-nl "/* Scanning closure data ... */")
(do ((n (1- (fun-env fun)) (1- n))
@ -477,29 +432,30 @@
cfun (fun-file-position fun))))
(format stream "~%};")))))
(defun t2fset (c1form &rest args)
(declare (ignore args))
(t2ordinary nil c1form))
(defun c2fset (c1form fun fname macro 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!
(new-local fun)
(return-from c2fset))
(unless (and (not (fun-closure fun))
(eq *destination* 'TRASH))
(return-from c2fset
(c2call-global c1form 'SI:FSET c1forms)))
(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!
(new-local fun)
(if macro
(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)))

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

@ -20,16 +20,72 @@
(local var))
(let ((var1 (c1form-arg 0 form)))
(declare (type var var1))
(when (and ;; Fixme! We should be able to replace variable
;; even if they are referenced across functions.
;; We just need to keep track of their uses.
(local var1)
(eq (unboxed var) (unboxed var1))
(not (var-changed-in-form-list var1 rest-forms)))
;; FIXME We should be able to replace variable even if they are referenced
;; across functions. We just need to keep track of their uses.
(when (and (local var1)
(eq (unboxed var) (unboxed var1))
(not (var-changed-in-form-list var1 rest-forms)))
(cmpdebug "Replacing variable ~a by its value" (var-name var))
(nsubst-var var form)
t))))
(defun locative-type-from-var-kind (kind)
(cdr (assoc kind
'((:object . "_ecl_object_loc")
(:fixnum . "_ecl_fixnum_loc")
(:char . "_ecl_base_char_loc")
(:float . "_ecl_float_loc")
(:double . "_ecl_double_loc")
(:long-double . "_ecl_long_double_loc")
#+complex-float (:csfloat . "_ecl_csfloat_loc")
#+complex-float (:cdfloat . "_ecl_cdfloat_loc")
#+complex-float (:clfloat . "_ecl_clfloat_loc")
#+sse2 (:int-sse-pack . "_ecl_int_sse_pack_loc")
#+sse2 (:float-sse-pack . "_ecl_float_sse_pack_loc")
#+sse2 (:double-sse-pack . "_ecl_double_sse_pack_loc")
((special global closure lexical) . NIL)))))
(defun build-debug-lexical-env (var-locations &optional first)
#-:msvc ;; FIXME! Problem with initialization of statically defined vectors
(let* ((filtered-locations '())
(filtered-codes '()))
;; Filter out variables that we know how to store in the debug information
;; table. This excludes among other things closures and special variables.
(loop for var in var-locations
for name = (let ((*package* (find-package "KEYWORD")))
(format nil "\"~S\"" (var-name var)))
for code = (locative-type-from-var-kind (var-kind var))
for loc = (var-loc var)
when (and code (consp loc) (eq (first loc) 'LCL))
do (progn
(push (cons name code) filtered-codes)
(push loc filtered-locations)))
;; Generate two tables, a static one with information about the variables,
;; including name and type, and dynamic one, which is a vector of pointer to
;; the variables.
(when filtered-codes
(setf *ihs-used-p* t)
(wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={")
(loop for (name . code) in filtered-codes
for i from 0
do (wt-nl (if (zerop i) "{" ",{") name "," code "}"))
(wt "};")
(wt-nl "const cl_index _ecl_debug_info_raw[]={")
(wt-nl (if first "(cl_index)(ECL_NIL)," "(cl_index)(_ecl_debug_env),")
"(cl_index)(_ecl_descriptors)")
(loop for var-loc in filtered-locations
do (wt ",(cl_index)(&" var-loc ")"))
(wt "};")
(wt-nl "ecl_def_ct_vector(_ecl_debug_env,ecl_aet_index,_ecl_debug_info_raw,"
(+ 2 (length filtered-locations))
",,);")
(unless first
(wt-nl "ihs.lex_env = _ecl_debug_env;")))
filtered-codes))
(defun pop-debug-lexical-env ()
(wt-nl "ihs.lex_env = _ecl_debug_env;"))
(defun c2let* (c1form vars forms body
&aux
(*volatile* (c1form-volatile* c1form))
@ -76,14 +132,14 @@
;; Optionally register the variables with the IHS frame for debugging
(if (policy-debug-variable-bindings)
(let ((*unwind-exit* *unwind-exit*))
(wt-nl-open-brace)
(let* ((env (build-debug-lexical-env vars)))
(when env (push 'IHS-ENV *unwind-exit*))
(c2expr body)
(wt-nl-close-brace)
(when env (pop-debug-lexical-env))))
(with-lexical-scope ()
(ext:if-let ((env (build-debug-lexical-env vars)))
(progn
(push 'IHS-ENV *unwind-exit*)
(c2expr body)
(pop-debug-lexical-env))
(c2expr body))))
(c2expr body))
(close-inline-blocks))
(defun c2multiple-value-bind (c1form vars init-form body)
@ -94,16 +150,13 @@
(*lcl* *lcl*)
(labels nil)
(env-grows nil)
(nr (make-lcl-var :type :int))
(*inline-blocks* 0)
min-values max-values)
(declare (ignore nr))
;; 1) Retrieve the number of output values
;; 1) Retrieve the number of output values.
(multiple-value-setq (min-values max-values)
(c1form-values-number init-form))
;; 2) For all variables which are not special and do not belong to
;; a closure, make a local C variable.
;; 2) For all variables which are not special and do not belong to a
;; closure, make a local C variable.
(dolist (var vars)
(declare (type var var))
(let ((kind (local var)))
@ -114,22 +167,18 @@
(wt-nl (rep-type->c-name kind) " " *volatile* var ";")
(wt-comment (var-name var)))
(unless env-grows (setq env-grows (var-ref-ccb var))))))
;; 3) If there are closure variables, set up an environment.
(when (setq env-grows (env-grows env-grows))
(let ((env-lvl *env-lvl*))
(maybe-open-inline-block)
(wt-nl "volatile cl_object env" (incf *env-lvl*)
" = env" env-lvl ";")))
;; 4) Assign the values to the variables, compiling the form
;; and binding the variables in the process.
;; 4) Assign the values to the variables, compiling the form and binding the
;; variables in the process.
(do-m-v-setq vars init-form t)
;; 5) Compile the body. If there are bindings of special variables,
;; these bindings are undone here.
;; 5) Compile the body. If there are bindings of special variables, these
;; bindings are undone here.
(c2expr body)
;; 6) Close the C expression.
(close-inline-blocks)))
@ -137,7 +186,7 @@
(unwind-exit (precise-loc-type loc (c1form-primary-type c1form))))
;;; When LOC is not NIL, then the variable is a constant.
(defun c2var (c1form var loc)
(defun c2variable (c1form var loc)
(unwind-exit (precise-loc-type
(if (and loc (not (numberp (vv-location loc))))
loc
@ -160,14 +209,13 @@
(lcl (next-lcl))
(sym-loc (make-lcl-var))
(val-loc (make-lcl-var)))
(wt-nl-open-brace)
(wt-nl "cl_object " sym-loc ", " val-loc "; cl_index " lcl ";")
(let ((*destination* sym-loc)) (c2expr* symbols))
(let ((*destination* val-loc)) (c2expr* values))
(let ((*unwind-exit* (cons lcl *unwind-exit*)))
(wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
(c2expr body)
(wt-nl-close-brace))))
(with-lexical-scope ()
(wt-nl "cl_object " sym-loc ", " val-loc "; cl_index " lcl ";")
(let ((*destination* sym-loc)) (c2expr* symbols))
(let ((*destination* val-loc)) (c2expr* values))
(let ((*unwind-exit* (cons lcl *unwind-exit*)))
(wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
(c2expr body)))))
(defun c2psetq (c1form vrefs forms
&aux (*lcl* *lcl*) (saves nil) (braces *opened-c-braces*))
@ -195,8 +243,10 @@
(let ((*destination* (make-temp-var)))
(c2expr* form)
(push (cons var *destination*) saves)))))
(let ((*destination* var)) (c2expr* form))))
(dolist (save saves) (set-var (cdr save) (car save)))
(let ((*destination* var))
(c2expr* form))))
(dolist (save saves)
(set-var (cdr save) (car save)))
(wt-nl-close-many-braces braces)
(unwind-exit *vv-nil*))
@ -313,7 +363,7 @@
(declare (ignore max-values))
;; We save the values in the value stack + value0
(let ((*destination* 'RETURN))
(let ((*destination* 'LEAVE))
(c2expr* form))
;; At least we always have NIL value0
@ -322,29 +372,28 @@
(let* ((*lcl* *lcl*)
(useful-extra-vars (some #'useful-var-p (nthcdr min-values vars)))
(nr (make-lcl-var :type :int)))
(wt-nl-open-brace)
(when useful-extra-vars
;; Make a copy of env->nvalues before assigning to any variables
(wt-nl "const int " nr " = cl_env_copy->nvalues;"))
(with-lexical-scope ()
(when useful-extra-vars
;; Make a copy of env->nvalues before assigning to any variables
(wt-nl "const int " nr " = cl_env_copy->nvalues;"))
;; We know that at least MIN-VALUES variables will get a value
(dotimes (i min-values)
(when vars
(let ((v (pop vars))
(loc (values-loc-or-value0 i)))
(bind-or-set loc v use-bind))))
;; We know that at least MIN-VALUES variables will get a value
(dotimes (i min-values)
(when vars
(let ((v (pop vars))
(loc (values-loc-or-value0 i)))
(bind-or-set loc v use-bind))))
;; Assign to other variables only when the form returns enough values
(when useful-extra-vars
(let ((tmp (make-lcl-var)))
(wt-nl "cl_object " tmp ";")
(loop for v in vars
for i from min-values
for loc = (values-loc-or-value0 i)
do (when (useful-var-p v)
(wt-nl tmp " = (" nr "<=" i ")? ECL_NIL : " loc ";")
(bind-or-set tmp v use-bind)))))
(wt-nl-close-brace))
;; Assign to other variables only when the form returns enough values
(when useful-extra-vars
(let ((tmp (make-lcl-var)))
(wt-nl "cl_object " tmp ";")
(loop for v in vars
for i from min-values
for loc = (values-loc-or-value0 i)
do (when (useful-var-p v)
(wt-nl tmp " = (" nr "<=" i ")? ECL_NIL : " loc ";")
(bind-or-set tmp v use-bind)))))))
'VALUE0))
(defun c2multiple-value-setq (c1form vars form)
@ -361,8 +410,7 @@
(if (safe-compile)
(wt "ecl_cmp_symbol_value(cl_env_copy," var-loc ")")
(wt "ECL_SYM_VAL(cl_env_copy," var-loc ")")))
(t (wt var-loc))
)))
(t (wt var-loc)))))
(defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb
(unless (var-p var)
@ -389,10 +437,26 @@
(wt #\;))
))
(defun wt-lcl (lcl)
(unless (numberp lcl)
(baboon :format-control "wt-lcl: ~s NaN"
:format-arguments (list lcl)))
(wt "v" lcl))
(defun wt-lcl-loc (lcl &optional type name)
(declare (ignore type))
(unless (numberp lcl)
(baboon :format-control "wt-lcl-loc: ~s NaN"
:format-arguments (list lcl)))
(wt "v" lcl name))
(defun wt-lex (lex)
(if (consp lex)
(wt "lex" (car lex) "[" (cdr lex) "]")
(wt-lcl lex)))
(defun wt-temp (temp)
(wt "T" temp))
;;; reference to variable of inner closure.
(defun wt-env (clv) (wt "ECL_CONS_CAR(CLV" clv ")"))

4
src/cmp/cmpfun.lsp
View file

@ -14,6 +14,9 @@
(in-package #:compiler)
(defun register-function (fun)
(push fun *functions*))
(defun child-function-p (presumed-parent fun)
(declare (optimize speed))
(loop for real-parent = (fun-parent fun)
@ -86,7 +89,6 @@
(setf (var-ref-clb var) nil
(var-ref-ccb var) t
(var-kind var) 'CLOSURE
(var-loc var) 'OBJECT
to-be-updated
(prepend-new (var-functions-reading var)
(prepend-new (var-functions-setting var)

8
src/cmp/cmpglobals.lsp
View file

@ -65,6 +65,7 @@ running the compiler. It may be updated by running ")
;;; List of callbacks to be generated
;;;
(defvar *callbacks* nil)
(defvar *functions* nil)
;;; --cmpc-machine.lsp, cmpffi.lsp ---
(defvar *machine* nil)
@ -123,10 +124,10 @@ 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*.")
;;; --cmplog.lsp--
;;; --cmplocs.lsp--
;;;
;;; Destination of output of different forms. See cmploc.lsp for types
;;; of destinations.
;;; Destination of output of different forms. See cmplocs.lsp for types of
;;; destinations.
;;;
(defvar *destination*)
@ -238,6 +239,7 @@ be deleted if they have been opened with LoadLibrary.")
(*compiler-in-use* t)
(*compiler-phase* 't1)
(*callbacks* nil)
(*functions* nil)
(*cmp-env-root* (copy-tree *cmp-env-root*))
(*cmp-env* nil)
(*load-objects* (make-hash-table :size 128 :test #'equal))

71
src/cmp/cmplocs.lsp
View file

@ -85,41 +85,34 @@
(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 CALL-STACK)
: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
(when (atom loc)
(return-from loc-with-side-effects-p
(and (var-p loc)
(global-var-p loc)
(policy-global-var-checking))))
(case (first loc)
((CALL CALL-NORMAL CALL-INDIRECT CALL-STACK) T)
(CL:THE (loc-with-side-effects-p (third loc)))
(CL:FDEFINITION (policy-global-function-checking))
;; Uses VALUES or has side effects.
(FFI:C-INLINE (or (eq (sixth loc) 'CL:VALUES) (fifth loc)))
(otherwise NIL)))
(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)))
(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)))
;;; Valid locations are:
;;; NIL
;;; T
;;; fixnum
;;; VALUE0
;;; VALUES
;;; VALUEZ
;;; var-object
;;; a string designating a C expression
;;; ( VALUE i ) VALUES(i)
@ -144,22 +137,22 @@
;;; Valid *DESTINATION* locations are:
;;;
;;; VALUE0
;;; RETURN Object returned from current function.
;;; var-object Variable
;;; loc-object VV Location
;;; TRASH Value may be thrown away.
;;; VALUES Values vector.
;;; var-object
;;; ( LCL lcl )
;;; ( LEX lex-address )
;;; 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
(VALUES 'VALUES)
(VALUEZ 'VALUEZ)
(TRASH 'TRASH)
(T 'RETURN)))
(T 'LEAVE)))
(defun precise-loc-type (loc new-type)
(if (subtypep (loc-type loc) new-type)
@ -174,7 +167,7 @@
t)
((vv-p loc)
t)
((member loc '(value0 values va-arg cl-va-arg))
((member loc '(VALUE0 VALUEZ VA-ARG CL-VA-ARG))
nil)
((atom loc)
(baboon :format-control "Unknown location ~A found in C1FORM"

8
src/cmp/cmpmain.lsp
View file

@ -284,7 +284,7 @@ from the C language code. NIL means \"do not create the file\"."
(*compiler-output2* (if h-file
(open h-file :direction :output :external-format :default)
null-stream))
(t3local-fun (symbol-function 'T3LOCAL-FUN))
(t3function (symbol-function 'T3FUNCTION))
(compiler-conditions nil)
(*cmp-env-root* *cmp-env-root*))
(with-compiler-env (compiler-conditions)
@ -292,10 +292,10 @@ from the C language code. NIL means \"do not create the file\"."
(setf disassembled-form (set-closure-env disassembled-form lexenv *cmp-env-root*))
(unwind-protect
(progn
(setf (symbol-function 'T3LOCAL-FUN)
(setf (symbol-function 'T3FUNCTION)
#'(lambda (&rest args)
(let ((*compiler-output1* *standard-output*))
(apply t3local-fun args))))
(apply t3function args))))
(compiler-pass1 disassembled-form)
(compiler-pass/propagate-types)
(optimize-cxx-data *referenced-objects*)
@ -304,7 +304,7 @@ from the C language code. NIL means \"do not create the file\"."
(if data-file data-file ""))
(when data-file
(data-c-dump data-file)))
(setf (symbol-function 'T3LOCAL-FUN) t3local-fun)
(setf (symbol-function 'T3FUNCTION) t3function)
(when h-file (close *compiler-output2*))))))
nil)

81
src/cmp/cmppackage.lsp
View file

@ -3,55 +3,54 @@
;;;;
;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll
;;;; Copyright (c) 2023, Daniel Kochmański
;;;;
;;;; 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.
;;;;
;;;; CMPPACKAGE -- Package definitions and exported symbols
;;;; See the file 'LICENSE' for the copyright details.
;;;;
(defpackage #:c
(:nicknames #:compiler)
(:use #:cl)
(:import-from #:ext #:install-c-compiler)
;;;; CMPPACKAGE -- Package definitions and exported symbols
(defpackage "C"
(:nicknames "ECL-CMP" "COMPILER")
(:local-nicknames ("OP" "ECL-CMP/OP"))
(:use "CL")
(:import-from "EXT" "INSTALL-C-COMPILER")
(:export
;; Flags controlling the compiler behavior.
#:*compiler-break-enable*
#:*compile-print*
#:*compile-to-linking-call*
#:*compile-verbose*
#:*compiler-features*
#:*cc*
#:*cc-optimize*
#:*user-cc-flags*
#:*user-ld-flags* ; deprecated
#:*user-linker-flags*
#:*user-linker-libs*
#:*suppress-compiler-messages*
"*COMPILER-BREAK-ENABLE*"
"*COMPILE-PRINT*"
"*COMPILE-TO-LINKING-CALL*"
"*COMPILE-VERBOSE*"
"*COMPILER-FEATURES*"
"*CC*"
"*CC-OPTIMIZE*"
"*USER-CC-FLAGS*"
"*USER-LD-FLAGS*" ; deprecated
"*USER-LINKER-FLAGS*"
"*USER-LINKER-LIBS*"
"*SUPPRESS-COMPILER-MESSAGES*"
;; Build targets. BUILD-ECL is not defined, preasumbly it was meant
;; for cross compilation.
#:build-ecl
#:build-program
#:build-fasl
#:build-static-library
#:build-shared-library
"BUILD-ECL"
"BUILD-PROGRAM"
"BUILD-FASL"
"BUILD-STATIC-LIBRARY"
"BUILD-SHARED-LIBRARY"
;; Conditions (and their accessors).
#:compiler-warning
#:compiler-note
#:compiler-message
#:compiler-error
#:compiler-fatal-error
#:compiler-internal-error
#:compiler-undefined-variable
#:compiler-message-file
#:compiler-message-file-position
#:compiler-message-form
"COMPILER-WARNING"
"COMPILER-NOTE"
"COMPILER-MESSAGE"
"COMPILER-ERROR"
"COMPILER-FATAL-ERROR"
"COMPILER-INTERNAL-ERROR"
"COMPILER-UNDEFINED-VARIABLE"
"COMPILER-MESSAGE-FILE"
"COMPILER-MESSAGE-FILE-POSITION"
"COMPILER-MESSAGE-FORM"
;; Other operators.
#:install-c-compiler
#:update-compiler-features))
"INSTALL-C-COMPILER"
"UPDATE-COMPILER-FEATURES"))
(ext:package-lock '#:cl nil)

6
src/cmp/cmppass1-eval.lsp
View file

@ -26,9 +26,9 @@
(make-c1form* 'LOCATION :type (object-type form)
:args (add-symbol form)))
((constantp form *cmp-env*)
(c1var form (c1constant-symbol-value form (symbol-value form))))
(c1variable form (c1constant-symbol-value form (symbol-value form))))
(t
(c1var form nil))))
(c1variable form nil))))
((consp form)
(cmpck (not (si:proper-list-p form))
"Improper list found in lisp form~%~A" form)
@ -213,4 +213,4 @@
;;; if this occurred in a proclaimed fun.
(defun c1values (args)
(make-c1form* 'VALUES :args (c1args* args)))
(make-c1form* 'CL:VALUES :args (c1args* args)))

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

@ -49,8 +49,7 @@
(dolist (def (nreverse defs))
(let ((fun (first def)))
;; The closure type will be fixed later on by COMPUTE-...
(push (c1compile-function (rest def) :fun fun)
local-funs))))
(push (c1compile-function (rest def) :fun fun) local-funs))))
;; When we are in a LABELs form, we have to propagate the external
;; variables from one function to the other functions that use it.

90
src/cmp/cmppass1-top.lsp
View file

@ -29,46 +29,44 @@
(*current-form* form)
(*setjmps* 0))
(setq form (chk-symbol-macrolet form))
(when (consp form)
(let ((fun (car form)) (args (cdr form)) fd)
(when (member fun *toplevel-forms-to-print*)
(print-current-form))
(cond
((consp fun) (t1ordinary form))
((not (symbolp fun))
(cmperr "~s is illegal function." fun))
((eq fun 'QUOTE)
(t1ordinary 'NIL))
((setq fd (gethash fun *t1-dispatch-table*))
(funcall fd args))
((gethash fun *c1-dispatch-table*)
(t1ordinary form))
((and (setq fd (cmp-compiler-macro-function fun))
(inline-possible fun)
(let ((success nil))
(multiple-value-setq (fd success)
(cmp-expand-macro fd form))
success))
(when *compile-time-too*
;; Ignore compiler macros during compile time evaluation
;; (they may expand in ffi:c-inline which the bytecodes
;; compiler can't execute).
(cmp-eval form))
(let ((*compile-time-too* nil))
(push 'macroexpand *current-toplevel-form*)
(t1expr* fd)))
((setq fd (cmp-macro-function fun))
(unless (consp form)
(return-from t1expr* (t1ordinary 'NIL)))
(let ((fun (car form)) (args (cdr form)) fd)
(when (member fun *toplevel-forms-to-print*)
(print-current-form))
(cond
((consp fun) (t1ordinary form))
((not (symbolp fun))
(cmperr "~s is illegal function." fun))
((eq fun 'QUOTE)
(t1ordinary 'NIL))
((setq fd (gethash fun *t1-dispatch-table*))
(funcall fd args))
((gethash fun *c1-dispatch-table*)
(t1ordinary form))
((and (setq fd (cmp-compiler-macro-function fun))
(inline-possible fun)
(let ((success nil))
(multiple-value-setq (fd success)
(cmp-expand-macro fd form))
success))
(when *compile-time-too*
;; Ignore compiler macros during compile time evaluation
;; (they may expand in ffi:c-inline which the bytecodes
;; compiler can't execute).
(cmp-eval form))
(let ((*compile-time-too* nil))
(push 'macroexpand *current-toplevel-form*)
(t1expr* (cmp-expand-macro fd form)))
(t (t1ordinary form))))))
(t1expr* fd)))
((setq fd (cmp-macro-function fun))
(push 'macroexpand *current-toplevel-form*)
(t1expr* (cmp-expand-macro fd form)))
(t (t1ordinary form)))))
(defun t1/c1expr (form)
(cond ((not *compile-toplevel*)
(c1expr form))
((atom form)
(t1ordinary form))
(t
(t1expr* form))))
(if (not *compile-toplevel*)
(c1expr form)
(t1expr* form)))
(defun c1eval-when (args)
(check-args-number 'EVAL-WHEN args 1)
@ -141,7 +139,7 @@
(setf loc (add-object (cmp-eval form)))))
(make-c1form* 'LOCATION :type t :args loc)))
;;; ----------------------------------------------------------------------
;;; ----------------------------------------------------------------------------
;;; Optimizer for FSET. Removes the need for a special handling of DEFUN as a
;;; toplevel form and also allows optimizing calls to DEFUN or DEFMACRO which
;;; are not toplevel, but which create no closures.
@ -152,9 +150,13 @@
;;; the compiler we do not know whether a function is a closure, hence the need
;;; for a c2fset.
;;;
;;; We optimize (SYS:FSET #'(LAMBDA ...) ..) and also, accidentally,
;;; (SYS:FSET (FLET ((FOO ...)) #'FOO) ...) which is to what LAMBDA gets
;;; translated in c1function.
;;; We optimize:
;;;
;;; (SYS:FSET NAME #'(LAMBDA ...) ...)
;;;
;;; where LAMBDA is expanded by C1FUNCTION to:
;;;
;;; (SYS:FSET NAME (FLET ((FOO ...)) #'FOO))
;;;
(defun t1fset (args)
(let ((form `(si::fset ,@args)))
@ -180,12 +182,10 @@
(every #'global-var-p (fun-referenced-vars fun-object))
;; Referencing the function variable
(eq (c1form-name form) 'VARIABLE)
(eq (c1form-arg 0 form)
(fun-var fun-object)))
(eq (c1form-arg 0 form) (fun-var fun-object)))
(when (fun-no-entry fun-object)
(when macro
(cmperr "Declaration C-LOCAL used in macro ~a"
(fun-name fun-object)))
(cmperr "Declaration C-LOCAL used in macro ~a." fname))
(return-from c1fset
(make-c1form* 'SI:FSET :args fun-object nil nil nil nil)))
(when (and (typep macro 'boolean)

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

@ -243,7 +243,7 @@
:ref 0)))))
;;; When LOC is not NIL then we deal with a constant.
(defun c1var (name loc)
(defun c1variable (name loc)
(let* ((var (c1vref name))
(output (make-c1form* 'VARIABLE
:type (var-type var)
@ -271,8 +271,7 @@
((CLOSURE))
((LEXICAL)
(when cfb
(setf (var-ref-clb var) t
(var-loc var) 'OBJECT)))
(setf (var-ref-clb var) t)))
(t
(when cfb
(cmperr "Variable ~A declared of C type cannot be referenced across function boundaries."

16
src/cmp/cmprefs.lsp
View file

@ -49,14 +49,7 @@
(functions-setting nil)
(functions-reading nil)
;;; Functions in which the variable has been modified or read.
(loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can
;;; be allocated on the c-stack: OBJECT means
;;; the variable is declared as OBJECT, and CLB means
;;; the variable is referenced across Level Boundary and thus
;;; cannot be allocated on the C stack. Note that OBJECT is
;;; set during variable binding and CLB is set when the
;;; variable is used later, and therefore CLB may supersede
;;; OBJECT.
(loc 'OBJECT) ;;; During Pass 1: OBJECT
;;; During Pass 2:
;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT:
;;; the cvar for the C variable that holds the value.
@ -122,8 +115,6 @@
(no-entry nil) ;;; NIL if declared as C-LOCAL. Then we create no
;;; function object and the C function is called
;;; directly
(shares-with nil) ;;; T if this function shares the C code with another one.
;;; In that case we need not emit this one.
closure ;;; During Pass2, T if env is used inside the function
var ;;; the variable holding the funob
description ;;; Text for the object, in case NAME == NIL.
@ -159,7 +150,7 @@
ref-clb ;;; Unused (see blk-var).
read-nodes ;;; Unused (see blk-var).
|#
exit ;;; Where to return. A label.
exit ;;; Where to return. A label.
destination ;;; Where the value of the block to go.
var ;;; Variable containing the block id and its references.
(type '(VALUES &REST T)) ;;; Estimated type.
@ -173,8 +164,7 @@
ref-clb ;;; Unused (see tag-var).
read-nodes ;;; Unused (see tag-var).
|#
label ;;; Where to jump: a label.
unwind-exit ;;; Where to unwind-no-exit.
jump ;;; Where to escape. A label.
var ;;; Variable containing frame ID.
index ;;; An integer denoting the label.
)

26
src/cmp/cmptables.lsp
View file

@ -36,7 +36,6 @@
(CL:FUNCTION fname :single-valued)
(LOCALS local-fun-list body labels-p :pure)
;; Specialized accessors
(CL:RPLACD (dest-c1form value-c1form) :side-effects)
(SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
(SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects)
;; Control structures
@ -155,17 +154,15 @@
))
(defconstant +set-loc-dispatch-alist+
'((bind . bind)
(jump-true . set-jump-true)
(jump-false . set-jump-false)
(cl:values . set-values-loc)
(value0 . set-value0-loc)
(cl:return . set-return-loc)
(trash . set-trash-loc)
'((bind . bind)
(cl:the . set-the-loc)
))
(valuez . set-valuez-loc)
(value0 . set-value0-loc)
(leave . set-leave-loc)
(trash . set-trash-loc)
(jump-true . set-trash-loc)
(jump-false . set-trash-loc)
(ffi-data-ref . wt-ffi-data-set)))
(defconstant +wt-loc-dispatch-alist+
'((call-normal . wt-call-normal)
@ -184,11 +181,12 @@
(make-cclosure . wt-make-closure)
(si:structure-ref . wt-structure-ref)
(ffi-data-ref . wt-ffi-data-ref)
(cl:return . "value0")
(cl:values . "cl_env_copy->values[0]")
(leave . "value0")
(va-arg . "va_arg(args,cl_object)")
(cl-va-arg . "ecl_va_arg(args)")
(valuez . "cl_env_copy->values[0]")
(value0 . "value0")))
(defconstant +c2-dispatch-alist+
@ -224,7 +222,7 @@
(cl:tagbody . c2tagbody)
(cl:go . c2go)
(variable . c2var)
(variable . c2variable)
(location . c2location)
(cl:setq . c2setq)
(cl:progv . c2progv)

8
src/cmp/cmputil.lsp
View file

@ -70,8 +70,8 @@
(restart-case
(handler-bind ((compiler-note #'handle-compiler-note)
(warning #'handle-compiler-warning)
(compiler-error #'handle-compiler-error)
(compiler-internal-error #'handle-compiler-internal-error)
(compiler-error #'handle-compiler-error)
(serious-condition #'handle-compiler-internal-error))
(mp:with-lock (mp:+load-compile-lock+)
(let ,+init-env-form+
@ -489,3 +489,9 @@ comparing circular objects."
(defun same-fname-p (name1 name2)
(equal name1 name2))
(defun emptyp (item)
(etypecase item
(list (null item))
(vector (zerop (length item)))
(hash-table (zerop (hash-table-count item)))))

26
src/cmp/cmpvar.lsp
View file

@ -27,22 +27,6 @@
(baboon :format-control "In REPLACEABLE, variable ~A not found. Form:~%~A"
:format-arguments (list (var-name var) *current-form*))))
#+not-used
(defun discarded (var form body &aux last)
(labels ((last-form (x &aux (args (c1form-args x)))
(case (c1form-name x)
(PROGN
(last-form (car (last (first args)))))
((LET LET* FLET LABELS BLOCK CATCH)
(last-form (car (last args))))
(VARIABLE (c1form-arg 0 x))
(t x))))
(and (not (c1form-side-effects form))
(or (< (var-ref var) 1)
(and (= (var-ref var) 1)
(eq var (last-form body))
(eq 'TRASH *destination*))))))
(defun nsubst-var (var form)
(when (var-set-nodes var)
(baboon :format-control "Cannot replace a variable that is to be changed"))
@ -56,16 +40,6 @@
(c1form-replace-with where form))
(setf (var-ignorable var) 0))
#+not-used
(defun member-var (var list)
(let ((kind (var-kind var)))
(if (member kind '(SPECIAL GLOBAL))
(member var list :test
#'(lambda (v1 v2)
(and (member (var-kind v2) '(SPECIAL GLOBAL))
(eql (var-name v1) (var-name v2)))))
(member var list))))
;;;
(defun make-var (&rest args)

17
src/h/bytecodes.h
View file

@ -1,16 +1,13 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/**********************************************************************
***
*** IMPORTANT: ANY CHANGE IN THIS FILE MUST BE MATCHED BY
*** APPROPRIATE CHANGES IN THE INTERPRETER AND COMPILER
*** IN PARTICULAR, IT MAY HURT THE THREADED INTERPRETER
*** CODE.
**********************************************************************/
/*
* See ecl/src/c/interpreter.d for a detailed explanation of all opcodes
*/
/* -----------------------------------------------------------------------------
*** IMPORTANT: ANY CHANGE IN THIS FILE MUST BE MATCHED BY APPROPRIATE CHANGES
*** IN THE INTERPRETER AND COMPILER IN PARTICULAR, IT MAY HURT THE THREADED
*** INTERPRETER CODE.
----------------------------------------------------------------------------- */
/* See ecl/src/c/interpreter.d for a detailed explanation of all opcodes. */
enum {
OP_NOP,
OP_QUOTE,

1
src/h/stacks.h
View file

@ -312,6 +312,7 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr);
ecl_enable_interrupts_env(env)
#define ecl_frs_pop(env) ((env)->frs_top--)
#define ecl_frs_pop_n(env,n) ((env)->frs_top-=n)
/*******************
* ARGUMENTS STACK