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

cmp: exit manager has now two main ops UNWIND-EXIT and UNWIND-JUMP

Browse source 
unwind-exit assigns the destination and jumps to the target
unwind-jump ignores the destination and jumps to the target
This commit is contained in:
Daniel Kochmański 2023-11-15 12:36:04 +01:00
parent 4d412cc6f9
commit 38e45ad026
8 changed files with 38 additions and 64 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -38,18 +38,19 @@
;;; *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--
;;;
;;; *exit* holds an 'exit', which is
;; LABEL instance or LEAVE.
;;; *unwind-exit* holds a list consisting of:
;; LABEL instance, LEAVE, 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 *exit*)

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

@ -110,6 +110,10 @@
;;; LABELS AND JUMPS
;;;
(defun wt-nl-go (label)
(wt-nl-indent)
(wt-go label))
(defun wt-go (label)
(setf (label-used-p label) t)
(wt "goto L" (label-id label) ";"))

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

@ -82,7 +82,7 @@
(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 (eq ue 'BDS-BIND) (eq ue 'FRAME))
(return nil))
@ -103,8 +103,7 @@
(let ((*destination* 'TRASH))
;; We do not provide any C2FORM.
(c2psetq nil (cdr *tail-recursion-info*) args)))
(unwind-no-exit 'TAIL-RECURSION-MARK)
(wt-nl "goto TTL;")
(unwind-jump *tail-recursion-mark*)
(cmpdebug "Tail-recursive call of ~s was replaced by iteration." (fun-name fun))
t))

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

@ -124,12 +124,8 @@
(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* (tag-jump tag))
(wt-nl) (wt-go (tag-jump 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)

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

@ -154,43 +154,25 @@
(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)))))
(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)))))
(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)))))
(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)))))
(defun c2mv-prog1 (c1form form body)
(wt-nl-open-brace)

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

@ -37,7 +37,6 @@
;;; #<label id used-p> -> label (basic block leader)
;;; (LCL n) -> n local variables
;;; (STACK n) -> n elements pushed in stack
;;; TAIL-RECURSION-MARK -> TTL: label created
;;; LEAVE -> outermost location
(defun unwind-stacks (frs-bind bds-lcl bds-bind stack-frame ihs-p)
@ -52,7 +51,7 @@
(wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");"))
(if (< bds-bind 4)
(dotimes (n bds-bind)
(declare (ignore n))
(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
@ -88,7 +87,6 @@
(setf ihs-p (or ihs-p ue)))
((eq ue 'LEAVE)
(setf exit-p t))
((eq ue 'TAIL-RECURSION-MARK))
(t (baboon-unwind-exit ue)))
finally (return (values frs-bind bds-lcl bds-bind stack-frame ihs-p jump-p exit-p))))
@ -96,8 +94,7 @@
(unwind-delta (or (member exit *unwind-exit* :test #'eq)
(baboon-exit-not-found exit))))
(defun unwind-exit (loc &aux (jump-p nil) (frs-bind 0) (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil))
(declare (fixnum frs-bind bds-bind))
(defun unwind-exit (loc)
(when (consp *destination*)
(case (car *destination*)
(JUMP-TRUE
@ -110,6 +107,7 @@
(return-from unwind-exit)))))
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p jump-p exit-p)
(unwind-delta* *exit*)
(declare (fixnum frs-bind bds-bind))
(assert (null exit-p)) ; this operator does not cross the function boundary.
(when (eq *exit* 'LEAVE)
;; *destination* must be either LEAVE or TRASH.
@ -148,15 +146,10 @@
(unwind-stacks 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)
(wt-go *exit*))))
(wt-nl-go *exit*))))
(defun unwind-no-exit (exit)
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
(unwind-delta* exit)
(unwind-stacks frs-bind bds-lcl bds-bind stack-frame ihs-p)))
(defun unwind-no-exit* (exit)
(defun unwind-jump (exit)
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
(unwind-delta (label-denv exit))
(unwind-stacks frs-bind bds-lcl bds-bind stack-frame ihs-p)))
(unwind-stacks frs-bind bds-lcl bds-bind stack-frame ihs-p)
(wt-nl-go exit)))

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

@ -293,14 +293,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)

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

@ -288,6 +288,7 @@
(*ihs-used-p* nil)
(*opened-c-braces* 0)
(*tail-recursion-info* fun)
(*tail-recursion-mark* nil)
(*volatile* (c1form-volatile* lambda-expr)))
(t3function-declaration fun)
(wt-nl-open-brace)