;;; CMPTAG Tagbody and Go. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL 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, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (import 'si::switch) (import 'si::switch-finish) (si:putprop 'tagbody 'c1tagbody 'c1special) (si:putprop 'tagbody 'c2tagbody 'c2) (si:putprop 'go 'c1go 'c1special) (si:putprop 'go 'c2go 'c2) (defstruct tag name ;;; Tag name. ref ;;; Referenced or not. T or NIL. ref-clb ;;; Cross local function reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; tagbody id, or NIL. ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; block id, or NIL. label ;;; Where to jump. A label. unwind-exit ;;; Where to unwind-no-exit. var ;;; The tag-name holder. A VV index. switch ;;; tag for switch. A fixnum or 'default ) (defvar *tags* nil) ;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB' ;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on ;;; *tags* when the compiler begins to process a closure. 'LB' will be pushed ;;; on *tags* when *level* is incremented. (defun jumps-to-p (clause tag-name &aux tem) ;;Does CLAUSE have a go TAG-NAME in it? (cond ((atom clause)nil) ((and (eq (car clause) 'go) (tag-p (setq tem (cadddr (cdr clause)))) (eq (tag-name tem) tag-name))) (t (or (jumps-to-p (car clause) tag-name) (jumps-to-p (cdr clause) tag-name))))) (defvar *reg-amount* 60) ;;amount to increase var-register for each variable reference in side a loop (defun add-reg1 (form) ;;increase the var-register in FORM for all vars (cond ((atom form) (cond ((typep form 'var) (setf (var-register form) (the fixnum (+ (the fixnum (var-register form)) (the fixnum *reg-amount*)))) ))) (t (add-reg1 (car form)) (add-reg1 (cdr form))))) (defun add-loop-registers (tagbody) ;;Find a maximal iteration interval in TAGBODY from first to end ;;then increment the var-register slot. (do ((v tagbody (cdr v)) (end nil) (first nil)) ((null v) (do ((ww first (cdr ww))) ((eq ww end)(add-reg1 (car ww))) (add-reg1 (car ww)))) (cond ((typep (car v) 'tag) (or first (setq first v)) (do ((w (cdr v) (cdr w)) (name (tag-name (car v)))) ((null w) ) (cond ((jumps-to-p (car w) name) (setq end w)))))))) (defun c1tagbody (body &aux (*tags* *tags*) (info (make-info))) ;;; Establish tags. (setq body (mapcar #'(lambda (x) (cond ((or (symbolp x) (integerp x)) (let ((tag (make-tag :name x :ref nil :ref-ccb nil :ref-clb nil))) (push tag *tags*) tag)) (t x))) body)) ;;; Process non-tag forms. (setq body (mapcar #'(lambda (x) (if (typep x 'tag) x (c1expr* x info))) body)) ;;; Delete redundant tags. (do ((l body (cdr l)) (body1 nil) (ref nil) (ref-clb nil) (ref-ccb nil)) ((endp l) (if (or ref-ccb ref-clb ref) (progn (setq body1 (reverse body1)) (cond ((or ref-clb ref-ccb) (incf *setjmps*)) (t (add-loop-registers body1 ))) (list 'tagbody info ref-clb ref-ccb body1)) (list 'progn info (reverse (cons (c1nil) body1))))) (declare (object l ref ref-clb ref-ccb)) (if (typep (car l) 'tag) (cond ((tag-ref-ccb (car l)) (push (car l) body1) (setf (tag-var (car l)) (add-object (tag-name (car l)))) (setq ref-ccb t)) ((tag-ref-clb (car l)) (push (car l) body1) (setf (tag-var (car l)) (add-object (tag-name (car l)))) (setq ref-clb t)) ((tag-ref (car l)) (push (car l) body1) (setq ref t))) (push (car l) body1)))) (defun c2tagbody (ref-clb ref-ccb body) (cond (ref-ccb (c2tagbody-ccb body)) (ref-clb (c2tagbody-clb body)) (t (c2tagbody-local body)))) (defun c2tagbody-local (body &aux (label (next-label))) ;;; Allocate labels. (dolist** (x body) (when (typep x 'tag) (setf (tag-label x) (next-label*)) (setf (tag-unwind-exit x) label))) (let ((*unwind-exit* (cons label *unwind-exit*))) (c2tagbody-body body)) ) (defun c2tagbody-body (body) (do ((l body (cdr l)) (written nil)) ((endp (cdr l)) (cond (written (unwind-exit nil)) ((typep (car l) 'tag) (wt-switch-case (tag-switch (car l))) (wt-label (tag-label (car l))) (unwind-exit nil)) (t (let* ((*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*)) (*value-to-go* 'trash)) (c2expr (car l)) (wt-label *exit*)) (unless (eq (caar l) 'go) (unwind-exit nil))))) (declare (object l written)) (cond (written (setq written nil)) ((typep (car l) 'tag) (wt-switch-case (tag-switch (car l))) (wt-label (tag-label (car l)))) (t (let* ((*exit* (if (typep (cadr l) 'tag) (progn (setq written t) (tag-label (cadr l))) (next-label))) (*unwind-exit* (cons *exit* *unwind-exit*)) (*value-to-go* 'trash)) (c2expr (car l)) (and (typep (cadr l) 'tag) (wt-switch-case (tag-switch (cadr l)))) (wt-label *exit*)))))) (defun c2tagbody-clb (body &aux (label (next-label)) (*vs* *vs*)) (let ((*unwind-exit* (cons 'frame *unwind-exit*)) (ref-clb (vs-push))) (wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();") (wt-nl "frs_push(FRS_CATCH,") (wt-vs ref-clb) (wt ");") (wt-nl "if(nlj_active){") (wt-nl "nlj_active=FALSE;") ;;; Allocate labels. (dolist** (tag body) (when (typep tag 'tag) (setf (tag-label tag) (next-label*)) (setf (tag-unwind-exit tag) label) (when (tag-ref-clb tag) (setf (tag-ref-clb tag) ref-clb) (wt-nl "if(eql(nlj_tag,VV[" (tag-var tag) "]))") (wt-go (tag-label tag))))) (wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);") (wt-nl "}") (let ((*unwind-exit* (cons label *unwind-exit*))) (c2tagbody-body body)))) (defun c2tagbody-ccb (body &aux (label (next-label)) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (let ((*unwind-exit* (cons 'frame *unwind-exit*)) (ref-clb (vs-push)) ref-ccb) (wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();") (wt-nl) (wt-vs ref-clb) (wt "=MMcons(") (wt-vs ref-clb) (wt ",") (wt-clink) (wt ");") (clink ref-clb) (setq ref-ccb (ccb-vs-push)) (wt-nl "frs_push(FRS_CATCH,") (wt-vs* ref-clb) (wt ");") (wt-nl "if(nlj_active){") (wt-nl "nlj_active=FALSE;") ;;; Allocate labels. (dolist** (tag body) (when (typep tag 'tag) (setf (tag-label tag) (next-label*)) (setf (tag-unwind-exit tag) label) (when (or (tag-ref-clb tag) (tag-ref-ccb tag)) (setf (tag-ref-clb tag) ref-clb) (when (tag-ref-ccb tag) (setf (tag-ref-ccb tag) ref-ccb)) (wt-nl "if(eql(nlj_tag,VV[" (tag-var tag) "]))") (wt-go (tag-label tag))))) (wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);") (wt-nl "}") (let ((*unwind-exit* (cons label *unwind-exit*))) (c2tagbody-body body)))) (defun c1go (args) (cond ((endp args) (too-few-args 'go 1 0)) ((not (endp (cdr args))) (too-many-args 'go 1 (length args))) ((not (or (symbolp (car args)) (integerp (car args)))) "The tag name ~s is not a symbol nor an integer." (car args))) (do ((tags *tags* (cdr tags)) (name (car args)) (ccb nil) (clb nil)) ((endp tags) (cmperr "The tag ~s is undefined." name)) (declare (object name ccb clb)) (case (car tags) (cb (setq ccb t)) (lb (setq clb t)) (t (when (eq (tag-name (car tags)) name) (let ((tag (car tags))) (cond (ccb (setf (tag-ref-ccb tag) t)) (clb (setf (tag-ref-clb tag) t)) (t (setf (tag-ref tag) t))) (return (list 'go *info* clb ccb tag)))))))) (defun c2go (clb ccb tag) (cond (ccb (c2go-ccb tag)) (clb (c2go-clb tag)) (t (c2go-local tag)))) (defun c2go-local (tag) (unwind-no-exit (tag-unwind-exit tag)) (wt-nl) (wt-go (tag-label tag))) (defun c2go-clb (tag) (wt-nl "vs_base=vs_top;") (wt-nl "unwind(frs_sch(") (if (tag-ref-ccb tag) (wt-vs* (tag-ref-clb tag)) (wt-vs (tag-ref-clb tag))) (wt "),VV[" (tag-var tag) "]);")) (defun c2go-ccb (tag) (wt-nl "{frame_ptr fr;") (wt-nl "fr=frs_sch(") (wt-ccb-vs (tag-ref-ccb tag)) (wt ");") (wt-nl "if(fr==NULL)FEerror(\"The GO tag ~s is missing.\",1,VV[" (tag-var tag) "]);") (wt-nl "vs_base=vs_top;") (wt-nl "unwind(fr,VV[" (tag-var tag) "]);}")) (defun wt-switch-case (x) (cond (x (wt-nl (if (typep x 'fixnum) "case " "") x ":")))) (defun c1switch(form &aux (*tags* *tags*)) (let* ((switch-op (car form)) (body (cdr form)) (switch-op-1 (c1expr switch-op))) (cond ((and (typep (second switch-op-1 ) 'info) (subtypep (info-type (second switch-op-1)) 'fixnum)) ;;optimize into a C switch: ;;If we ever get GCC to do switch's with an enum arg, ;;which don't do bounds checking, then we will ;;need to carry over the restricted range. ;;more generally the compiler should carry along the original type ;;decl, not just the coerced one. This needs another slot in ;;info. (or (member t body) (setq body (append body (list t)))) (setq body (mapcar #'(lambda (x) (cond ((or (symbolp x) (integerp x)) (let ((tag (make-tag :name x :ref nil :ref-ccb nil :ref-clb nil))) (cond((typep x 'fixnum) (setf (tag-ref tag) t) (setf (tag-switch tag) x)) ((eq t x) (setf (tag-ref tag) t) (setf (tag-switch tag) "default"))) tag)) (t x))) body)) (let ((tem (c1tagbody `(,@ body switch-finish-label)))) (nconc (list 'switch (cadr tem) switch-op-1) (cddr tem)) )) (t (c1expr (cmp-macroexpand-1 (cons 'switch form))))))) (defun c2switch (op ref-clb ref-ccb body &aux (*inline-blocks* 0)(*vs* *vs*)) (let ((args (inline-args (list op ) '(fixnum )))) (wt-inline-loc "switch(#0){" args) (cond (ref-ccb (c2tagbody-ccb body)) (ref-clb (c2tagbody-clb body)) (t (c2tagbody-local body))) (wt "}") (unwind-exit nil) (close-inline-blocks))) ;; SWITCH construct for Common Lisp. (TEST &body BODY) (in package SI) ;; TEST must evaluate to something of INTEGER TYPE. If test matches one ;; of the labels (ie integers) in the body of switch, control will jump ;; to that point. It is an error to have two or more constants which are ;; eql in the the same switch. If none of the constants match the value, ;; then control moves to a label T. If there is no label T, control ;; flows as if the last term in the switch were a T. It is an error ;; however if TEST were declared to be in a given integer range, and at ;; runtime a value outside that range were provided. The value of a ;; switch construct is undefined. If you wish to return a value use a ;; block construct outside the switch and a return-from. `GO' may also ;; be used to jump to labels in the SWITCH. ;; Control falls through from case to case, just as if the cases were ;; labels in a tagbody. To jump to the end of the switch, use ;; (switch-finish). ;; The reason for using a new construct rather than building on CASE, is ;; that CASE does not allow the user to use invoke a `GO' if necessary. ;; to switch from one case to another. Also CASE does not allow sharing ;; of parts of code between different cases. They have to be either the ;; same or disjoint. ;; The SWITCH may be implemented very efficiently using a jump table, if ;; the range of cases is not too much larger than the number of cases. ;; If the range is much larger than the number of cases, a binary ;; splitting of cases might be used. ;; Sample usage: ;; (defun goo (x) ;; (switch x ;; 1 (princ "x is one, ") ;; 2 (princ "x is one or two, ") ;; (switch-finish) ;; 3 (princ "x is three, ") ;; (switch-finish) ;; t (princ "none"))) ;; We provide a Common Lisp macro for implementing the above construct: (defmacro switch (test &body body &aux cases) (dolist (v body) (cond ((integerp v) (push `(if (eql ,v ,test) (go ,v) nil) cases)))) `(tagbody ,@ (nreverse cases) (go t) ,@ body ,@ (if (member t body) nil '(t)) switch-finish-label )) (defmacro switch-finish nil '(go switch-finish-label)) (si::putprop 'switch 'c1switch 'c1special) (si::putprop 'switch 'c2switch 'c2)