mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-18 23:32:17 -08:00
cmp: exit manager: implement branching directly in the module
Instead of open-coding branching manually in individual operators we introduce separate unwinding operators.
This commit is contained in:
Daniel Kochmański
parent
bb42ed7194
commit
a12d24a8bf
3 changed files with 124 additions and 98 deletions
|
|
@ -79,10 +79,12 @@
|
|||
(wt-nl "cl_object " tag-loc ";"))
|
||||
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc)
|
||||
(with-unwind-frame (tag-loc)
|
||||
(do-tags (tag body (when (var-ref-ccb tag-loc)
|
||||
(wt-nl "ecl_internal_error(\"GO found an inexistent tag\");")))
|
||||
(wt-nl "if (cl_env_copy->values[0]==ecl_make_fixnum(" (tag-index tag) "))")
|
||||
(unwind-cond (tag-jump tag)))
|
||||
(progn
|
||||
(do-tags (tag body nil)
|
||||
(unwind-cond (tag-jump tag) :jump-eq
|
||||
'VALUEZ (tag-index tag)))
|
||||
(when (var-ref-ccb tag-loc)
|
||||
(wt-nl "ecl_internal_error(\"GO found an inexistent tag\");")))
|
||||
(c2tagbody-body body))
|
||||
(close-inline-blocks)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -137,8 +137,7 @@
|
|||
(dolist (f butlast)
|
||||
(let ((*destination* 'VALUE0))
|
||||
(c2expr* f))
|
||||
(wt-nl "if (" 'VALUE0 "!=ECL_NIL) ")
|
||||
(unwind-cond normal-exit))
|
||||
(unwind-cond normal-exit :jump-t 'VALUE0))
|
||||
(c2expr last))
|
||||
(unwind-exit 'VALUE0)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -35,35 +35,18 @@
|
|||
(t (baboon-exit-invalid *exit*)))))
|
||||
|
||||
(defun unwind-jump (exit)
|
||||
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(compute-unwind (label-denv exit) *unwind-exit*)
|
||||
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(wt-nl-go exit)))
|
||||
(%unwind (label-denv exit) *unwind-exit*)
|
||||
(%goto exit))
|
||||
|
||||
;;; A conditional jump that is meant to be used as the IF statement body.
|
||||
;;; FIXME we want UNWIND-JEQL and UNWIND-JNOT and open-code the test too.
|
||||
(defun unwind-cond (exit)
|
||||
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(compute-unwind (label-denv exit) *unwind-exit*)
|
||||
(with-lexical-scope ()
|
||||
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(wt-nl-go exit))))
|
||||
(defun unwind-cont (exit)
|
||||
(%unwind (label-denv exit) *unwind-exit*)
|
||||
(%goto exit))
|
||||
|
||||
(defun unwind-flee (exit kind)
|
||||
;; All these boil down to calling ecl_unwind which unwinds stacks dynamically.
|
||||
;; If we want to implement call/cc, then this is the place where we dispatch.
|
||||
#+ (or) (wt-nl "ecl_unwind(cl_env_copy," frs-id ");")
|
||||
(ecase kind
|
||||
(:go
|
||||
;; The second argument is passed as a value (index for jump).
|
||||
(wt-nl "cl_go(" (tag-var exit) ",ecl_make_fixnum(" (tag-index exit) "));"))
|
||||
(:throw
|
||||
;; Unlike GO and RETURN-FROM, the destination is not known at compile time.
|
||||
;; TODO in some cases it is possible to prove the destination CATCH form.
|
||||
(wt-nl "cl_throw(" exit ");"))
|
||||
(:return-from
|
||||
;; The second argument is used only to signal the error.
|
||||
(wt-nl "cl_return_from(" (blk-var exit) "," (get-object (blk-name exit)) ");"))))
|
||||
(%escape exit kind))
|
||||
|
||||
(defun unwind-cond (exit kind &rest args)
|
||||
(%branch exit *unwind-exit* kind args))
|
||||
|
||||
;;;
|
||||
|
||||
|
|
@ -100,24 +83,6 @@
|
|||
;;; LEAVE -> outermost location
|
||||
;;; #<label id used-p> -> label (basic block leader)
|
||||
|
||||
(defun perform-unwind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(declare (si::c-local)
|
||||
(fixnum frs-bind bds-bind))
|
||||
(when (plusp frs-bind)
|
||||
(wt-nl "ecl_frs_pop_n(cl_env_copy, " frs-bind ");"))
|
||||
(when stack-frame
|
||||
(wt-nl "ecl_stack_frame_close(" stack-frame ");"))
|
||||
(when bds-lcl
|
||||
(wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");"))
|
||||
(if (< bds-bind 4)
|
||||
(dotimes (n bds-bind)
|
||||
(declare (ignorable n))
|
||||
(wt-nl "ecl_bds_unwind1(cl_env_copy);"))
|
||||
(wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))
|
||||
(case ihs-p
|
||||
(IHS (wt-nl "ecl_ihs_pop(cl_env_copy);"))
|
||||
(IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;"))))
|
||||
|
||||
(defun compute-unwind (unwind-to unwind-from)
|
||||
(declare (si::c-local))
|
||||
(unless (tailp unwind-to unwind-from)
|
||||
|
|
@ -155,47 +120,34 @@
|
|||
|
||||
(defun unwind-leave (loc)
|
||||
(declare (si::c-local))
|
||||
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(compute-unwind nil *unwind-exit*)
|
||||
(declare (fixnum frs-bind bds-bind))
|
||||
;; *destination* must be either LEAVE or TRASH.
|
||||
(cond ((eq loc 'VALUEZ)
|
||||
;; from multiple-value-prog1 or values
|
||||
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(wt-nl "return cl_env_copy->values[0];"))
|
||||
((eq loc 'LEAVE)
|
||||
;; from multiple-value-prog1 or values
|
||||
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(wt-nl "return value0;"))
|
||||
(t
|
||||
(set-loc 'LEAVE loc)
|
||||
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(wt-nl "return value0;")))))
|
||||
;; *destination* must be either LEAVE or TRASH.
|
||||
(unless (member loc '(VALUEZ LEAVE))
|
||||
(set-loc 'LEAVE loc)
|
||||
(setf loc 'LEAVE))
|
||||
(%unwind nil *unwind-exit*)
|
||||
(%exit loc))
|
||||
|
||||
(defun unwind-label (loc)
|
||||
(declare (si::c-local))
|
||||
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p jump-p exit-p)
|
||||
(compute-unwind (or (member *exit* *unwind-exit* :test #'eq)
|
||||
(baboon-exit-not-found *exit*))
|
||||
*unwind-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*)
|
||||
(loc-refers-to-special-p *destination*))
|
||||
;; Save the value if *DESTINATION* may possibly refer to special
|
||||
;; binding. Otherwise we may set *DESTINATION* /before/ the unwind.
|
||||
(let* ((*temp* *temp*)
|
||||
(temp (make-temp-var)))
|
||||
(set-loc temp loc)
|
||||
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(set-loc *destination* temp)))
|
||||
(t
|
||||
(set-loc *destination* loc)
|
||||
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)))
|
||||
;; When JUMP-P is NULL then we "fall through" onto the exit block.
|
||||
(when jump-p
|
||||
(wt-nl-go *exit*))))
|
||||
(let* ((exit *exit*)
|
||||
(dest *destination*)
|
||||
(from *unwind-exit*)
|
||||
(exit-denv (member exit from :test #'eq)))
|
||||
(unless exit-denv
|
||||
(baboon-exit-not-found exit))
|
||||
(if (and (destination-value-matters-p dest)
|
||||
(loc-refers-to-special-p dest))
|
||||
;; Save the value if destination may possibly refer to a special
|
||||
;; binding. Otherwise we set the destination /before/ the unwind.
|
||||
(let* ((*temp* *temp*)
|
||||
(temp (make-temp-var)))
|
||||
(set-loc temp loc)
|
||||
(%unwind exit-denv from)
|
||||
(set-loc dest temp))
|
||||
(progn
|
||||
(set-loc dest loc)
|
||||
(%unwind exit-denv from)))
|
||||
(%jump exit from)))
|
||||
|
||||
;;; Conditional JUMP based on the value of *DESTINATION*. This allows FMLA to
|
||||
;;; jump over *EXIT* to skip the dead part of the computation. -- jd 2023-11-16
|
||||
|
|
@ -206,11 +158,7 @@
|
|||
(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)")))
|
||||
(unwind-cond label))
|
||||
(unwind-cond label :jump-t loc))
|
||||
((not (null value))
|
||||
(unwind-jump label)))
|
||||
(unless (and constantp (not (null value)))
|
||||
|
|
@ -220,11 +168,7 @@
|
|||
(unwind-leave *vv-nil*)))))
|
||||
(JUMP-FALSE
|
||||
(cond ((not constantp)
|
||||
(case (loc-representation-type loc)
|
||||
(:bool (wt-nl "if (!(" loc "))"))
|
||||
(:object (wt-nl "if (Null(" loc "))"))
|
||||
(otherwise (wt-nl "if (Null(") (wt-coerce-loc :object loc) (wt "))")))
|
||||
(unwind-cond label))
|
||||
(unwind-cond label :jump-f loc))
|
||||
((null value)
|
||||
(unwind-jump label)))
|
||||
(unless (and constantp (null value))
|
||||
|
|
@ -232,3 +176,84 @@
|
|||
(if (labelp *exit*)
|
||||
(unwind-label *vv-t*)
|
||||
(unwind-leave *vv-t*)))))))))
|
||||
|
||||
|
||||
;;; Helper functions
|
||||
;;;
|
||||
;;; These functions will be moved to codegen.
|
||||
|
||||
;;; INV this function arguments are procured by COMPUTE-UNWIND.
|
||||
(defun perform-unwind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(declare (si::c-local)
|
||||
(fixnum frs-bind bds-bind))
|
||||
(when (plusp frs-bind)
|
||||
(wt-nl "ecl_frs_pop_n(cl_env_copy, " frs-bind ");"))
|
||||
(when stack-frame
|
||||
(wt-nl "ecl_stack_frame_close(" stack-frame ");"))
|
||||
(when bds-lcl
|
||||
(wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");"))
|
||||
(if (< bds-bind 4)
|
||||
(dotimes (n bds-bind)
|
||||
(declare (ignorable n))
|
||||
(wt-nl "ecl_bds_unwind1(cl_env_copy);"))
|
||||
(wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))
|
||||
(case ihs-p
|
||||
(IHS (wt-nl "ecl_ihs_pop(cl_env_copy);"))
|
||||
(IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;"))))
|
||||
|
||||
(defun %unwind (into from)
|
||||
(declare (si::c-local))
|
||||
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(compute-unwind into from)
|
||||
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)))
|
||||
|
||||
(defun %branch (exit from kind args)
|
||||
(ecase kind
|
||||
(:jump-t
|
||||
(destructuring-bind (loc) args
|
||||
(case (loc-representation-type loc)
|
||||
(:bool (wt-nl "if (" loc ") "))
|
||||
(:object (wt-nl "if (" loc "!=ECL_NIL) "))
|
||||
(otherwise (wt-nl "if ((") (wt-coerce-loc :object loc) (wt ")!=ECL_NIL) ")))))
|
||||
(:jump-f
|
||||
(destructuring-bind (loc) args
|
||||
(case (loc-representation-type loc)
|
||||
(:bool (wt-nl "if (!(" loc ")) "))
|
||||
(:object (wt-nl "if (Null(" loc ")) "))
|
||||
(otherwise (wt-nl "if (Null(") (wt-coerce-loc :object loc) (wt ")) ")))))
|
||||
(:jump-eq
|
||||
(destructuring-bind (x y) args
|
||||
(wt-nl "if (" `(coerce-loc :object ,x) "==" `(coerce-loc :object ,y) ") "))))
|
||||
(wt-open-brace)
|
||||
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(compute-unwind (label-denv exit) from)
|
||||
(perform-unwind frs-bind bds-lcl bds-bind stack-frame ihs-p)
|
||||
(wt-nl-go exit))
|
||||
(wt-nl-close-brace))
|
||||
|
||||
(defun %escape (exit kind)
|
||||
;; All these boil down to calling ecl_unwind which unwinds stacks dynamically.
|
||||
;; If we want to implement call/cc, then this is the place where we dispatch.
|
||||
#+ (or) (wt-nl "ecl_unwind(cl_env_copy," frs-id ");")
|
||||
(ecase kind
|
||||
(:go
|
||||
;; The second argument is passed as a value (index for jump).
|
||||
(wt-nl "cl_go(" (tag-var exit) ",ecl_make_fixnum(" (tag-index exit) "));"))
|
||||
(:throw
|
||||
;; Unlike GO and RETURN-FROM, the destination is not known at compile time.
|
||||
;; TODO in some cases it is possible to prove the destination CATCH form.
|
||||
(wt-nl "cl_throw(" exit ");"))
|
||||
(:return-from
|
||||
;; The second argument is used only to signal the error.
|
||||
(wt-nl "cl_return_from(" (blk-var exit) "," (get-object (blk-name exit)) ");"))))
|
||||
|
||||
;;; JUMP is similar to %GOTO, but it allows a fallthough.
|
||||
(defun %jump (label from)
|
||||
(unless (eq label (find-if #'labelp from))
|
||||
(wt-nl-go label)))
|
||||
|
||||
(defun %goto (label)
|
||||
(wt-nl-go label))
|
||||
|
||||
(defun %exit (loc)
|
||||
(wt-nl "return " loc ";"))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue