home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmplabel.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  7.6 KB  |  216 lines
  1. ;;; CMPLABEL  Exit manager.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (defvar *last-label* 0)
  25. (defvar *exit*)
  26. (defvar *unwind-exit*)
  27. (defvar *record-call-info* nil)
  28.  
  29. ;;; *last-label* holds the label# of the last used label.
  30. ;;; *exit* holds an 'exit', which is
  31. ;;;    ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
  32. ;;;    RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-SHORT-FLOAT, or
  33. ;;;    RETURN-OBJECT).
  34. ;;; *unwind-exit* holds a list consisting of:
  35. ;;;    ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
  36. ;;;    JUMP, BDS-BIND (each pushed for a single special binding), and
  37. ;;;    cvar (which holds the bind stack pointer used to unbind).
  38.  
  39. (defmacro next-label () `(cons (incf *last-label*) nil))
  40.  
  41. (defmacro next-label* () `(cons (incf *last-label*) t))
  42.  
  43. (defmacro wt-label (label)
  44.   `(when (cdr ,label) (wt-nl1 "T" (car ,label) ":;")))
  45.  
  46. (defmacro wt-go (label)
  47.   `(progn (rplacd ,label t) (wt "goto T" (car ,label) ";")))
  48.  
  49.  
  50. (defvar *restore-avma* nil)
  51.  
  52. (defun unwind-bds (bds-cvar bds-bind)
  53.        (when (consp *inline-blocks*) (wt-nl "restore_avma; "))
  54.        (when bds-cvar (wt-nl "bds_unwind(V" bds-cvar ");"))
  55.        (dotimes* (n bds-bind) (wt-nl "bds_unwind1;")))
  56.  
  57. (defun unwind-exit (loc &optional (jump-p nil) fname
  58.                         &aux (*vs* *vs*) (bds-cvar nil) (bds-bind 0) type.wt)
  59.   (declare (fixnum bds-bind))
  60.   (and *record-call-info* (record-call-info loc fname))
  61.   (when (and (eq loc 'fun-val)
  62.              (not (eq *value-to-go* 'return))
  63.              (not (eq *value-to-go* 'top)))
  64.         (wt-nl) (reset-top))
  65.   (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-true))
  66.          (set-jump-true loc (cadr *value-to-go*))
  67.          (when (eq loc t) (return-from unwind-exit)))
  68.         ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-false))
  69.          (set-jump-false loc (cadr *value-to-go*))
  70.          (when (null loc) (return-from unwind-exit))))
  71.   (dolist* (ue *unwind-exit* (baboon))
  72.    (cond
  73.     ((consp ue)
  74.      (cond ((eq ue *exit*)
  75.         (cond ((and (consp *value-to-go*)
  76.             (or (eq (car *value-to-go*) 'jump-true)
  77.                 (eq (car *value-to-go*) 'jump-false)))
  78.            (unwind-bds bds-cvar bds-bind))
  79.           (t
  80.            (if (or bds-cvar   (plusp bds-bind))
  81.                           ;;; Save the value if LOC may possibly refer
  82.                           ;;; to special binding.
  83.                (if (and (consp loc)
  84.                 (or (and (eq (car loc) 'var)
  85.                      (member (var-kind (cadr loc))
  86.                          '(SPECIAL GLOBAL)))
  87.                     (member (car loc)
  88.                         '(SIMPLE-CALL
  89.                           INLINE
  90.                           INLINE-COND INLINE-FIXNUM
  91.                           INLINE-CHARACTER
  92.                           INLINE-INTEGER
  93.                           INLINE-LONG-FLOAT
  94.                           INLINE-SHORT-FLOAT))))
  95.                (cond ((and (consp *value-to-go*)
  96.                        (eq (car *value-to-go*) 'vs))
  97.                   (set-loc loc)
  98.                   (unwind-bds bds-cvar bds-bind))
  99.                  (t (let
  100.                     ((temp (list 'cvar (cs-push))))
  101.                       (let ((*value-to-go* temp))
  102.                     (set-loc loc))
  103.                       (unwind-bds bds-cvar bds-bind)
  104.                       (set-loc temp))))
  105.              (progn (unwind-bds bds-cvar bds-bind)
  106.                 (set-loc loc)))
  107.              (set-loc loc))))
  108.  
  109.         (when jump-p
  110.           (when (consp *inline-blocks*) (wt-nl "restore_avma; "))
  111.           (wt-nl) (wt-go *exit*))
  112.         (return))
  113.        (t (setq jump-p t))))
  114.     ((numberp ue) (setq bds-cvar ue bds-bind 0))
  115.     ((eq ue 'bds-bind) (incf bds-bind))
  116.     ((eq ue 'return)
  117.      (when (eq *exit* 'return)
  118.               ;;; *VALUE-TO-GO* must be either *RETURN* or *TRASH*.
  119.        (set-loc loc)
  120.        (unwind-bds bds-cvar bds-bind)
  121.        (wt-nl "return;")
  122.        (return))
  123.         ;;; Never reached
  124.      )
  125.     ((eq ue 'frame)
  126.      (when (and (consp loc)
  127.         (member (car loc)
  128.             '(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM inline-integer
  129.                       INLINE-CHARACTER INLINE-LONG-FLOAT
  130.                       INLINE-SHORT-FLOAT)))
  131.        (cond ((and (consp *value-to-go*)
  132.            (eq (car *value-to-go*) 'vs))
  133.           (set-loc loc)
  134.           (setq loc *value-to-go*))
  135.          (t (let ((*value-to-go* (if *c-gc* (list 'cvar (cs-push))
  136.                        (list 'vs (vs-push)))))
  137.           (set-loc loc)
  138.           (setq loc *value-to-go*)))))
  139.      (wt-nl "frs_pop();"))
  140.     ((eq ue 'tail-recursion-mark))
  141.     ((eq ue 'jump) (setq jump-p t))
  142.     ((setq type.wt
  143.        (assoc ue
  144.           '((return-fixnum fixnum .  wt-fixnum-loc)
  145.             (return-character character . wt-character-loc)
  146.             (return-short-float short-float . wt-short-float-loc)
  147.             (return-long-float long-float . wt-long-float-loc)
  148.             (return-object t . wt-loc))))
  149.      (let ((cvar (next-cvar)))
  150.        (or (eq *exit* (car type.wt)) (wfs-error))
  151.        (setq type.wt (cdr type.wt))
  152.        (wt-nl "{" (rep-type (car type.wt)) "V" cvar " = ")
  153.        (funcall (cdr type.wt) loc)  (wt ";")
  154.        (unwind-bds bds-cvar bds-bind)
  155.        (wt-nl "VMR" *reservation-cmacro* "(V" cvar")}")
  156.        (return)))
  157.         
  158.     (t (baboon))
  159.        ;;; Never reached
  160.     ))
  161.   )
  162.  
  163. (defun unwind-no-exit (exit &aux (bds-cvar nil) (bds-bind 0))
  164.   (declare (fixnum bds-bind))
  165.   (dolist* (ue *unwind-exit* (baboon))
  166.     (cond
  167.        ((consp ue)
  168.         (when (eq ue exit)
  169.               (unwind-bds bds-cvar bds-bind)
  170.               (return)))
  171.        ((numberp ue) (setq bds-cvar ue bds-bind 0))
  172.        ((eq ue 'bds-bind) (incf bds-bind))
  173.        ((member ue '(return return-object return-fixnum return-character
  174.                             return-long-float return-short-float))
  175.         (cond ((eq exit ue) (unwind-bds bds-cvar bds-bind)
  176.                             (return))
  177.               (t (baboon)))
  178.         ;;; Never reached
  179.         )
  180.        ((eq ue 'frame) (wt-nl "frs_pop();"))
  181.        ((eq ue 'tail-recursion-mark)
  182.         (cond ((eq exit 'tail-recursion-mark) (unwind-bds bds-cvar bds-bind)
  183.                                               (return))
  184.               (t (baboon)))
  185.         ;;; Never reached
  186.         )
  187.        ((eq ue 'jump))
  188.        (t (baboon))
  189.        ;;; Never reached
  190.        ))
  191.   )
  192.  
  193. ;;; Tail-recursion optimization for a function F is possible only if
  194. ;;;    1. the value of *DO-TAIL-RECURSION* is non-nil (this is default),
  195. ;;;    2. F receives only required parameters, and
  196. ;;;    3. no required parameter of F is enclosed in a closure.
  197. ;;;
  198. ;;; A recursive call (F e1 ... en) may be replaced by a loop only if
  199. ;;;    1. F is not declared as NOTINLINE,
  200. ;;;    2. n is equal to the number of required parameters of F,
  201. ;;;    3. the form is a normal function call (i.e. the arguments are
  202. ;;;       pushed on the stack,
  203. ;;;    4. (F e1 ... en) is not surrounded by a form that causes dynamic
  204. ;;;       binding (such as LET, LET*, PROGV),
  205. ;;;    5. (F e1 ... en) is not surrounded by a form that that pushes a frame
  206. ;;;       onto the frame-stack (such as BLOCK and TAGBODY whose tags are
  207. ;;;       enclosed in a closure, and CATCH),
  208.  
  209. (defun tail-recursion-possible ()
  210.   (dolist* (ue *unwind-exit* (baboon))
  211.     (cond ((eq ue 'tail-recursion-mark) (return t))
  212.           ((or (numberp ue) (eq ue 'bds-bind) (eq ue 'frame))
  213.            (return nil))
  214.           ((or (consp ue) (eq ue 'jump)))
  215.           (t (baboon)))))
  216.