;;;; -*- Mode:Common-Lisp; Package:Compiler; Base:10. -*- ;;; RESTRICTED RIGHTS LEGEND ;;; ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved. ;;; Copyright (C) 1980 Massachusetts Institute of Technology ;;;; *-----------------------------------------------------------* ;;;; | -- TI Explorer Lisp Compiler -- | ;;;; | This file defines the special-form handlers for pass 2. | ;;;; *-----------------------------------------------------------* ;;; Revision history: ;;; Feb. 1984 - Version 98 from MIT via LMI. ;;; July '84 through 4/30/85 - TI modifications for Explorer release 1.0. ;;; 06/26/85 - Minor modifications to improve speed of compilation. ;;; 07/10/85 - For release 3, file QCP2 split into P2DEFS, P2FUNS, and P2HAND. ;;; Aug. '85 through Aug. '86 - Modifications for Explorer release 3. ;;; 8/08/86 - Changes to handling of non-local lexical variables and breakoff-functions. ;;; 11/19/86 ;;; 12/09/86 DNG - Fix for THE around non-local lexical variable. ;;; 12/15/86 DNG - New handling for %BIND in LET with unknown number of result values. ;;; 12/23/86 DNG - Fix PDLLVL in P2SELECT. ;;; 12/31/86 DNG - Bind BDEST to NIL in P2SELECT. [SPR 2911] ;;; 2/04/87 DNG - Modify SIMPLEGOP for efficiency. ;;; 6/01/87 DNG - Fix (:PROPERTY UNSHARE-STACK-CLOSURE-VARS P2) for SPR 5599 and 5602. ;;;------------------ The following done after Explorer release 3.0 ------ ;;; 6/29/87 DNG - Fix (:PROPERTY UNSHARE-STACK-CLOSURE-VARS P2) and P2SELECT for SPR 5719. ;;; 7/07/87 DNG - Add (:PROPERTY QUOTE-LOAD-TIME-EVAL P2) as part of fix for SPR 4918. ;;; 7/13/87 DNG - Fix P2COND for SPR 5711. ;;;------------------ The following done for Explorer release 5.0 ------ ;;; 8/04/88 DNG - Added doc string for %PUSH. ;;; 8/25/88 clm - Fixed P2SETQ-1 to handle local variables moved to lexical environment ;;; by EXTEND-LOCAL-VARIABLES. ;;;------------------ The following done for Explorer release 6.0 ------ ;;; 3/15/89 DNG - Add support for CLOS. ;;; 3/16/89 DNG - Add handler for %load-time-value. ;;; 4/04/89 DNG - Fix P2LET-INTERNAL for SPR 9239. ;;; 4/05/89 DNG - Eliminated obsolete code for not (COMPILING-FOR-V2). ;;; 4/26/89 DNG - Redesigned the internal representation of LET forms -- this ;;; simplifies the code as well as facilitating further optimization ;;; and bug fixing. ;;; 5/03/89 DNG - Deleted P2LET and P2LET-INTERNAL [superseded by %LET ;;; handlers and P2LETX], P2SBIND and P2LMB [superseded by P2-S-BIND and ;;; P2SB1], and P2PBIND [superseded by P2-P-BIND]. ;;; 5/04/89 DNG - Add handler for SI:STORE-KEYARGS to enable optimizing to use ;;; aux-op %STORE-KEY-WORD-ARGS . ;Max index for the new AREFI and AREFI-SET series of instructions (DEFCONSTANT AREFI-MAX 63) (DEFPROP GLOBAL:AR-1 P2-AR-1 P2) (DEFPROP COMMON-LISP-AR-1 P2-AR-1 P2) (DEFPROP ARRAY-LEADER P2-AR-1 P2) (DEFPROP %INSTANCE-REF P2-AR-1 P2) (DEFUN P2-AR-1 (ARGL DEST) ;; 8/24/85 - Support PUSH-AR-1 instruction. ;; 9/26/85 - Modify format of the AREFI LAP instruction and ;; combine handlers for AR-1, COMMON-LISP-AR-1, and ARRAY-LEADER. (NO-D-RETURN (LET (INDEX) (IF (AND (NULL M-V-TARGET) (NOT GENERATING-MICRO-COMPILER-INPUT-P) (= (LENGTH ARGL) 2) (QUOTEP (SECOND ARGL)) (FIXNUMP (SETQ INDEX (SECOND (SECOND ARGL)))) (<= 0 (IF (EQ P2FN '%INSTANCE-REF) ;; %INSTANCE-REF is cretinously origin-1, but we are always origin-0. (SETQ INDEX (- INDEX 1)) INDEX) AREFI-MAX)) (PROGN (P2PUSH (FIRST ARGL)) (OUTI `(AREFI ,DEST ,P2FN ,INDEX))) (IF (AND (EQ DEST 'D-PDL) (EQ P2FN 'COMMON-LISP-AR-1) (INSTRUCTION-EXISTS-P 'PUSH-AR-1) (ADRREFP (FIRST ARGL)) (INDEPENDENT-EXPRESSIONS-P (FIRST ARGL) (SECOND ARGL))) (PROGN (P2PUSH (SECOND ARGL)) (OUTI `(PUSH-AR-1 0 ,(P2-SOURCE (FIRST ARGL) 'D-PDL)))) (P2MISC P2FN ARGL DEST 2)))))) (DEFPROP SET-AR-1 P2-SET-AR-1 P2) ; (SET-AR-1 array index value) (DEFPROP SET-ARRAY-LEADER P2-SET-AR-1 P2) ; (SET-ARRAY-LEADER array index value) (DEFPROP SET-%INSTANCE-REF P2-SET-AR-1 P2) (DEFUN P2-SET-AR-1 (ARGL DEST) ;; 9/26/85 - Modify format of the AREFI LAP instruction; ;; combine handlers for SET-AR-1 and SET-ARRAY-LEADER. ;; 6/04/86 - Fix to properly decrement index for SET-%INSTANCE-REF. (NO-D-RETURN (LET (INDEX) (IF (AND (NULL M-V-TARGET) (NOT GENERATING-MICRO-COMPILER-INPUT-P) (= (LENGTH ARGL) 3) (QUOTEP (SECOND ARGL)) (FIXNUMP (SETQ INDEX (SECOND (SECOND ARGL)))) (<= 0 (IF (EQ P2FN 'SET-%INSTANCE-REF) ;; %INSTANCE-REF is cretinously origin-1, but we are always origin-0. (SETQ INDEX (- INDEX 1)) INDEX) AREFI-MAX)) (PROGN (P2PUSH (FIRST ARGL)) (P2PUSH (THIRD ARGL)) (OUTI `(AREFI ,DEST ,P2FN ,INDEX))) (P2MISC P2FN ARGL DEST 3))))) (DEFPROP FUNCTION P2FUNCTION P2) (DEFUN P2FUNCTION (ARGL DEST) (OUTI `(MOVE ,DEST (QUOTE-VECTOR (FUNCTION ,(CAR ARGL)))))) ;; 8/8/86 DNG - deleted function P2BREAKOFF-FUNCTION. (DEFUN (:PROPERTY LEXICAL-CLOSURE P2) (ARGL DEST) ;; 1/09/86 DNG - New way of handling lexical closures for release 3. ;; 2/21/86 DNG - Add support for MAKE-EPHEMERAL-LEXICAL-CLOSURE. ;; 7/07/86 DNG - Get LOCAL-MAP from *CURRENT-COMPILAND*. ;; 7/12/86 DNG - First argument is compiland structure instead of BREAKOFF-FUNCTION form. ;; 7/15/86 DNG - Add update of CLOSURE-DISCONNECT-OFFSETS. ;; 5/03/89 DNG - Add debug assert. ;; If the following condition is not met, then there is no reason for this ;; to be a closure. Also, MAKE-LEXICAL-CLOSURE would return an illegal object. (debug-assert (or (> (car ENVIRONMENT-DESCRIPTOR-LIST) 0) (COMPILAND-LEXICAL-CLOSURE-FLAG *current-compiland*))) (NO-D-RETURN (P2PUSH-CONSTANT ENVIRONMENT-DESCRIPTOR-LIST) (WITH-STACK-LIST ( FORM 'BREAKOFF-FUNCTION (FIRST ARGL) ) (P2PUSH FORM) ) (OUTM `(MISC ,DEST ,(IF (SECOND ARGL) (MISC-LAP-CODE 'MAKE-EPHEMERAL-LEXICAL-CLOSURE) (MISC-LAP-CODE 'MAKE-LEXICAL-CLOSURE))))) (INCF LEXICAL-CLOSURE-COUNT)) (DEFPROP FUNCALL P2FUNCALL P2) (DEFUN P2FUNCALL (ARGL DEST) ;;DONT HACK PDLLVL HERE SINCE GOING TO POP 1 AND PUSH 4 ;; 8/28/86 CLM - no longer need DESC arg for P2ARGC (P2ARGC (CAR ARGL) (CDR ARGL) nil DEST NIL)) (DEFUN (:PROPERTY FUNCALL-WITH-MAPPING-TABLE-INTERNAL P2) (ARGL DEST) ;;DONT HACK PDLLVL HERE SINCE GOING TO POP 1 AND PUSH 4 ;; 8/28/86 CLM - no longer need DESC arg for call to P2ARGC (P2ARGC (CAR ARGL) (CDDR ARGL) nil DEST NIL (CADR ARGL))) (DEFPROP APPLY P2-LEXPR-FUNCALL P2) (DEFPROP LEXPR-FUNCALL P2-LEXPR-FUNCALL P2) (DEFUN P2-LEXPR-FUNCALL (ARGL DEST) ;; 10/28/85 CLM - Changed to generate Rel.3 aux-op APPLY ;; instead of obsolete misc-op APPLY. ;; 8/28/86 CLM - instead of a DESC arg, pass T to indicate this is a lexpr-funcall (IF (AND (= (LENGTH ARGL) 2) (NULL M-V-TARGET)) (PROGN (P2 (CADR ARGL) 'D-PDL) (P2 (CAR ARGL) 'D-PDL) (OUTI `(AUX APPLY ,DEST))) ;;DONT HACK PDLLVL HERE SINCE GOING TO POP 1 AND PUSH 4 (P2ARGC (CAR ARGL) (CDR ARGL) t DEST NIL))) (DEFUN (:PROPERTY LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL P2) (ARGL DEST) ;;DONT HACK PDLLVL HERE SINCE GOING TO POP 1 AND PUSH 4 ;; 8/28/86 CLM - instead of a DESC arg, pass T to indicate this is a lexpr-funcall (P2ARGC (CAR ARGL) (CDDR ARGL) t DEST NIL (CADR ARGL))) (DEFPROP VARIABLE-LOCATION P2VARIABLE-LOCATION P2) (DEFUN P2VARIABLE-LOCATION (ARGL DEST) ;; 8/24/85 - Change name of instruction PUSH-E to PUSH-LOC. ;; 1/09/86 - LOCATE-IN-HIGHER-CONTEXT instead of %LOCATE-IN-HIGHER-CONTEXT. ;; 1/14/86 - Use LEX addressing mode when possible. ;; 7/07/86 - Change handling of LEXICAL-REF addresses. ;;10/18/86 - Handle local variables moved to lexical environment by EXTEND-LOCAL-VARIABLES . (CASE (CAAR ARGL) (LOCAL-REF (LET ((A (VAR-LAP-ADDRESS (CADR (CAR ARGL))))) (IF (EQ (FIRST A) 'LEXICAL-REF) ; re-allocated by EXTEND-LOCAL-VARIABLES (P2VARIABLE-LOCATION (CONS A (REST ARGL)) DEST) (PROGN (OUTI `(PUSH-LOC 0 ,A)) (NEEDPDL 1) (MOVE-RESULT-FROM-PDL DEST))))) (LEXICAL-REF (LET ((ADR (LEX-REF-ADDRESS (CAR ARGL)))) (DECLARE (UNSPECIAL ADR)) (IF (CONSP ADR) (PROGN (OUTI `(PUSH-LOC 0 ,ADR)) (MOVE-RESULT-FROM-PDL DEST)) (PROGN (P2PUSH-CONSTANT ADR) (NEEDPDL 1) (OUTM '(MISC D-PDL LOCATE-IN-HIGHER-CONTEXT)) (MOVE-RESULT-FROM-PDL DEST))))) (SELF-REF (OUTI `(PUSH-LOC 0 (QUOTE-VECTOR ,(CAR ARGL)))) (NEEDPDL 1) (MOVE-RESULT-FROM-PDL DEST)) #+compiler:debug (OTHERWISE (BARF (FIRST ARGL) 'VARIABLE-LOCATION 'BARF)) )) ;;; %ACTIVATE-OPEN-CALL-BLOCK must ignore its apparent destination and ;;; instead compile to D-IGNORE (microcode depends on this). ;;; This fails to let the compiler know that the pdl is popped and a delayed ;;; transfer may be taken, but then it didn't know the pdl was pushed either. (DEFUN (:PROPERTY %ACTIVATE-OPEN-CALL-BLOCK P2) (IGNORE IGNORE) (WARN '%ACTIVATE-OPEN-CALL-BLOCK :IMPOSSIBLE "~A and ~A are no longer supported; use ~S." '%OPEN-CALL-BLOCK '%ACTIVATE-OPEN-CALL-BLOCK '%CALL) (P2ARGC NIL NIL NIL 'D-IGNORE '%ACTIVATE-OPEN-CALL-BLOCK)) (DEF %CALL) (DEFPROP %CALL (FUNCTION NUMBER-OF-ARGS &KEY :LEXPR :SELF-MAPPING-TABLE) ARGLIST) (SETF (DOCUMENTATION '%CALL 'FUNCTION) "Call a function, passing arguments that have already been pushed on the stack with %PUSH. This is a sub-primitive that only works in compiled code.") (DEFUN (:PROPERTY %CALL P2) (ARGL DEST) ;; 9/17/85 DNG - Original. This is an incomplete, preliminary version. ;; 10/23/85 DNG - Fix to not barf when only one argument. ;; 2/20/86 CLM - Add support for lexpr-funcalls, functions using self-mapping-table and ;; functions returning multiple values. ;; 9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET. (LET (LEXPR SELF-MAPPING-TABLE (CALL-INFO-WORD 0)) ;;argl should look like ;; fn nargs (quote :lexpr) (quote t/nil) (quote :self-mapping-table) (*) (DO ((KEYS (CDDR ARGL) (CDDR KEYS))) ((NULL KEYS)) (LET ((VALUE (CADR KEYS))) (CASE (SECOND (CAR KEYS)) (:LEXPR (UNLESS (QUOTEP VALUE) (WARN '%CALL :FATAL "~A is an invalid value for the keyword argument :LEXPR" VALUE)) (SETQ LEXPR (SECOND VALUE))) (:SELF-MAPPING-TABLE (SETQ SELF-MAPPING-TABLE VALUE)) (T (WARN '%CALL :FATAL "~A is an invalid keyword argument" (SECOND (CAR KEYS)))) ))) (COND ((OR (NULL (REST ARGL)) (AND (EQUAL (SECOND ARGL) ''0) (NULL (CDDR ARGL)))) (P2ARGC (FIRST ARGL) (QUOTE NIL) NIL DEST NIL)) ((OR LEXPR M-V-TARGET) (WHEN LEXPR (SETQ CALL-INFO-WORD (DPB 1 (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-LEXPR-FUNCALL-FLAG) CALL-INFO-WORD))) (WHEN M-V-TARGET (LET ((MVTARGET M-V-TARGET)) (SETQ M-V-TARGET NIL) ;;build call-info-word (COND ((EQ MVTARGET 'MULTIPLE-VALUE-LIST) (SETQ CALL-INFO-WORD (DPB (SYMEVAL-FOR-TARGET 'SI:%MULTIPLE-VALUE-LIST-RETURN) (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-RETURN-TYPE) CALL-INFO-WORD))) ((EQ MVTARGET 'THROW) (SETQ CALL-INFO-WORD (DPB (SYMEVAL-FOR-TARGET 'SI:%RETURN-ALL-VALUES-WITH-COUNT-ON-STACK) (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-RETURN-TYPE) CALL-INFO-WORD))) ((MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ) (SETQ CALL-INFO-WORD (DPB (SYMEVAL-FOR-TARGET 'SI:%RETURN-ALL-VALUES-WITH-COUNT-ON-STACK) (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-RETURN-TYPE) CALL-INFO-WORD))) ((NUMBERP MVTARGET) (SETQ CALL-INFO-WORD (DPB (SYMEVAL-FOR-TARGET 'SI:%NORMAL-RETURN) (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-RETURN-TYPE) CALL-INFO-WORD)) (SETQ CALL-INFO-WORD (DPB MVTARGET (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-NUMBER-OF-RESULTS) CALL-INFO-WORD)))))) ;;add the self-mapping-table bit to the call info word if necessary (WHEN SELF-MAPPING-TABLE (SETQ CALL-INFO-WORD (DPB 1 (SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-SELF-MAP-TABLE-PROVIDED) CALL-INFO-WORD)) (P2PUSH SELF-MAPPING-TABLE)) ;;place the number or args in the call-info-word and push (P2 `(DPB ,(SECOND ARGL) ',(SYMEVAL-FOR-TARGET 'SI:%%CALL-INFO-NUMBER-OF-ARGUMENTS) ',CALL-INFO-WORD) 'D-PDL) (P2PUSH (FIRST ARGL)) (OUTI1 (LIST 'AUX 'COMPLEX-CALL DEST)) ) (T (P2PUSH (SECOND ARGL)) ; number of arguments pushed (OUTI (LIST 'CALL-N DEST (P2-SOURCE (FIRST ARGL) 'D-PDL))) )))) (DEFUN (:PROPERTY %ASSURE-PDL-ROOM P2) (ARGL DEST) ;; 9/26/85 DNG - Original version. (P2PUSH (FIRST ARGL)) (OUT-AUX '%ASSURE-PDL-ROOM) (UNLESS (EQ DEST 'D-IGNORE) (P2 '(QUOTE NIL) DEST))) (DEF %PUSH ;; Don't actually call %PUSH, just push its argument (DEFPROP %PUSH P2%PUSH P2)) (SETF (GET '%PUSH 'ARGLIST) '(VALUE)) (SETF (DOCUMENTATION '%PUSH) "Push a value onto the stack.") (DEFUN P2%PUSH (ARGL IGNORE) (P2 (CAR ARGL) 'D-PDL)) (DEF %PUSH-VALUES-AND-COUNT) ;; Like %PUSH except that all the values produced by the form are pushed on the ;; stack, followed by the number of values on the top. (DEFUN (:PROPERTY %PUSH-VALUES-AND-COUNT P2) (ARGL DEST) (DECLARE (IGNORE DEST)) (WHEN (P2MV (FIRST ARGL) 'D-PDL 'RETURN) (P2PUSH-CONSTANT 1))) (DEFUN (:PROPERTY %DUP P2) (ARGL DEST) ;; Duplicate the top-of-stack. ;; This only works on an Explorer with microcode version 170 or later. ;; 1/4/85 - Original. (P2 (FIRST ARGL) 'D-PDL) (OUTI '(MOVEM 0 PDL-PUSH)) (MOVE-RESULT-FROM-PDL DEST) ) (DEF %EXCHANGE) ;; Push a value on the stack and then swap it with the previous top of stack. (DEFUN (:PROPERTY %EXCHANGE P2) (ARGL IGNORE) (P2 (CAR ARGL) 'D-PDL) (OUT-AUX 'EXCHANGE)) (DEFUN (:PROPERTY FLOOR P2) (ARGL DEST) (P2FLOOR 0 ARGL DEST)) (DEFUN (:PROPERTY CEILING P2) (ARGL DEST) (P2FLOOR 1 ARGL DEST)) (DEFUN (:PROPERTY TRUNCATE P2) (ARGL DEST) (P2FLOOR 2 ARGL DEST)) (DEFUN (:PROPERTY ROUND P2) (ARGL DEST) (P2FLOOR 3 ARGL DEST)) (DEFUN OUTFLOOR (ROUNDING-TYPE OPERATION) ;; 8/17/85 - Original. (OUTM `(MISC D-PDL ,OPERATION ,ROUNDING-TYPE))) ;There are two forms of them: FLOOR-2 returns two values, ;and FLOOR-1 returns only the first value. ;The value or values are left on the stack. ;We produce code to request one or two values and move them to ;the appropriate place. ;FLOOR, CEILING, TRUNCATE and ROUND are distinguished by ROUNDING-TYPE, ;which will be put into the destination field of the instruction. (DEFUN P2FLOOR (ROUNDING-TYPE ARGL DEST) ;; 8/17/85 - For release 2, add rounding type to MISC-OP code instead ;; of putting in the destination field. ;; 8/21/85 - Use OUT-AUX for %RETURN-2. ;; 9/25/85 - Changed name from INTERNAL-FLOOR-1 to FLOOR-1. ;; 10/28/85 CLM - Changed to generate Rel.3 aux-op %THROW-N ;; instead of misc-op THROW-N. ;; 2/17/86 DNG - Use (AUX RETURN-0 2) instead of %RETURN-2; ;; don't use RETURN-N-KEEP-CONTROL for VM2. ;; 7/16/86 CLM - No longer generate a throw here; this was causing too ;; many throws when there was an intervening CATCH between ;; the throw and its target. ;; 9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET. (P2PUSH (CAR ARGL)) (IF (CDR ARGL) (P2PUSH (CADR ARGL)) (P2PUSH-CONSTANT 1)) (ARGLOAD (CDDR ARGL) 'D-IGNORE) (COND ((EQ DEST 'D-RETURN) (OUTFLOOR ROUNDING-TYPE 'FLOOR-2) (OUTI '(AUX RETURN-0 2)) (SETQ DROPTHRU NIL)) ((NULL M-V-TARGET) (OUTFLOOR ROUNDING-TYPE 'FLOOR-1) (MOVE-RESULT-FROM-PDL DEST)) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (OUTFLOOR ROUNDING-TYPE 'FLOOR-2) (OUTM '(MISC D-PDL NCONS)) (OUTM '(MISC D-PDL CONS))) ((EQ M-V-TARGET 'THROW) (OUTFLOOR ROUNDING-TYPE 'FLOOR-2) (P2PUSH-CONSTANT 2)) ((MEMBER M-V-TARGET '(RETURN RETURN-CATCH) :TEST #'EQ) (OUTFLOOR ROUNDING-TYPE 'FLOOR-2) (P2PUSH-CONSTANT 2)) ((= M-V-TARGET 1) (OUTFLOOR ROUNDING-TYPE 'FLOOR-1)) (T (OUTFLOOR ROUNDING-TYPE 'FLOOR-2) (PUSH-NILS (- M-V-TARGET 2)))) (SETQ M-V-TARGET NIL)) (DEFUN (:PROPERTY MOD P2) (ARGL DEST) ;; 7/15/86 CLM - Fixed so that if DEST is D-INDS the ;; operation will be done. (UNLESS (EQ DEST 'D-IGNORE) (LET ((M-V-TARGET 2)) (P2FLOOR 0 ARGL 'D-PDL)) (UNLESS (EQ DEST 'D-RETURN) (P2PUSH-CONSTANT 1) (OUTM '(MISC D-PDL SHRINK-PDL-SAVE-TOP))) (MOVE-RESULT-FROM-PDL DEST))) (DEFUN (:PROPERTY REM P2) (ARGL DEST) ;; 7/15/86 CLM - Fixed so that if DEST is D-INDS the ;; operation will be done. (UNLESS (EQ DEST 'D-IGNORE) (LET ((M-V-TARGET 2)) (P2FLOOR 2 ARGL 'D-PDL)) (UNLESS (EQ DEST 'D-RETURN) (P2PUSH-CONSTANT 1) (OUTM '(MISC D-PDL SHRINK-PDL-SAVE-TOP))) (MOVE-RESULT-FROM-PDL DEST) )) #| (DEFUN (:PROPERTY GET P2) (ARGL DEST) ;; 4/23/85 DNG - Use two-argument instruction if the default ;; argument is 'NIL. (NO-D-RETURN (IF (OR (= (LENGTH ARGL) 2) (EQUAL (THIRD ARGL) '(QUOTE NIL))) (P2MISC 'GET ARGL DEST 2) (P2MISC 'INTERNAL-GET-3 ARGL DEST 3))) ) |# (DEFPROP SETQ P2SETQ P2) (DEFUN P2SETQ (ARGL DEST) (PROG NIL (OR ARGL (RETURN (P2 '(QUOTE NIL) DEST))) LOOP (P2SETQ-1 (CAR ARGL) (CADR ARGL) (IF (NULL (CDDR ARGL)) DEST 'D-IGNORE)) (SETQ ARGL (CDDR ARGL)) (AND ARGL (GO LOOP)))) ;Compile code to set VAR to the result of computing VALUE, ;and also move that value to DEST. (DEFUN P2SETQ-1 (VAR VALUE DEST) ;; 12/26/84 DNG - Modified to use P2-DESTINATION instead of P2-SOURCE. ;; 7/10/85 DNG - Use 'SETE property for release 3. ;; 8/24/85 DNG - Use SET-T instruction. ;; 8/25/88 clm - Handle local variables moved to lexical environment by EXTEND-LOCAL-VARIABLES . ;; 5/03/89 DNG - Add handling for FEF-INI-SETQ. (LET (INSTR) (COND ((MEMBER VAR '(NIL T) :TEST #'EQ) NIL) ((AND (EQ (CAR-SAFE VAR) 'LOCAL-REF) (EQ (VAR-KIND (SECOND VAR)) 'FEF-ARG-DELETED)) ;; SETQ-OPT decided that this SETQ was going to assign the initial value ;; of the variable, but %LET-OPT decided later that the variable wasn't ;; needed at all. So just evaluate the value expression without storing ;; it anywhere. (DEBUG-ASSERT (EQ (VAR-INIT-KIND (SECOND VAR)) 'FEF-INI-SETQ)) (UNLESS (AND (EQ DEST 'D-IGNORE) (NO-SIDE-EFFECTS-P VALUE)) (P2 VALUE DEST))) ((AND (CONSP VAR) (or (EQ (CAR VAR) 'LEXICAL-REF) (and (eq (car var) 'local-ref) (eq (car (var-lap-address (second var))) 'lexical-ref) (atom (lex-ref-address (var-lap-address (second var))))))) (P2PUSH VALUE) (MOVEM-AND-MOVE-TO-DEST VAR DEST)) ((MEMBER VALUE '('0 (QUOTE NIL)) :TEST #'EQUAL) (OUTI `(,(CDR (ASSOC (CADR VALUE) '((0 . SET-ZERO) (NIL . SET-NIL)) :TEST #'EQ)) 0 ,(P2-DESTINATION VAR))) (UNLESS (MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ) (P2 VALUE DEST))) ((AND (EQUAL VALUE ''T) (INSTRUCTION-EXISTS-P 'SET-T)) (OUTI `(SET-T 0 ,(P2-DESTINATION VAR))) (UNLESS (MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ) (P2 VALUE DEST))) ((AND (NOT (ATOM VALUE)) (CDR VALUE) (EQUAL (CADR VALUE) VAR) (SETQ INSTR (GET-FOR-TARGET (CAR VALUE) 'SETE)) (MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ)) (OUTI `(,INSTR D-INDS ,(P2-DESTINATION VAR)))) (T (P2PUSH VALUE) (MOVEM-AND-MOVE-TO-DEST VAR DEST)))) NIL) (DEFUN (:PROPERTY PUSH-CDR-STORE-CAR-IF-CONS P2) (ARGL DEST) ;; Used for MATCHCARCDR in file SYS:SYS2;SELEV ;; 12/26/84 DNG - Modified to use P2-DESTINATION. (P2PUSH (CAR ARGL)) (IF (ADRREFP (CADR ARGL)) (PROGN (OUTI `(PUSH-CDR-STORE-CAR-IF-CONS ,(P2-DESTINATION (CADR ARGL)))) (UNLESS (EQ DEST 'D-INDS) (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'INDICATORS-VALUE))))) (LET ((TAG (GENSYM))) (OUTM '(MISC D-INDS CONSP-OR-POP)) (OUTB `(BRANCH NULL TRUE NIL ,TAG)) (OUTM '(MISC D-PDL CARCDR)) (MOVEM-AND-MOVE-TO-DEST (CADR ARGL) 'D-IGNORE) (OUTTAG TAG) (UNLESS (EQ DEST 'D-INDS) (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'INDICATORS-VALUE))))))) (DEFUN (:PROPERTY PUSH-CDR-IF-CAR-EQUAL P2) (ARGL DEST) ;; Used by P1 handler for SI:MATCHCARCDR ;; 12/04/85 DNG - Modified to not use P2NODEST. (P2 (CAR ARGL) 'D-PDL) (OUTI `(PUSH-CDR-IF-CAR-EQUAL 0 ,(P2-SOURCE (CADR ARGL) 'D-INDS))) (UNLESS (EQ DEST 'D-INDS) (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'INDICATORS-VALUE))))) (DEFUN (:PROPERTY %DOLIST P2) (ARGL DEST) ;; %DOLIST is used in optimizer which expands DOLIST ;; 12/26/84 DNG - Use P2-DESTINATION instead of P2-SOURCE. ;; 4/09/85 DNG - Set TAGOUT to T. ;; 6/02/86 DNG - Bind TAGOUT to T instead of just SETQing it. (IGNORE DEST) (LET ((TOP-TAG (GENSYM)) (BOTTOM-TAG (GENSYM)) (PDLLVL PDLLVL)) (P2PUSH (SECOND ARGL)) (INCPDLLVL) (OUTB `(BRANCH ALWAYS NIL NIL ,TOP-TAG)) (OUTTAG TOP-TAG) (LET ((TAGOUT T)) (OUTI `(PUSH-CDR-STORE-CAR-IF-CONS ,(P2-DESTINATION (FIRST ARGL)))) (OUTB `(BRANCH NULL TRUE NIL ,BOTTOM-TAG)) (P2 (THIRD ARGL) 'D-IGNORE) (OUTB `(BRANCH ALWAYS NIL NIL ,TOP-TAG)) (OUTTAG BOTTOM-TAG) ))) (DEFUN (:PROPERTY THE-EXPR P2) (ARGL DEST) ;; THE-EXPR forms are generated by P1-WITH-ANNOTATION. ;; 1/28/85 -Original version. ;; 3/11/86 - Call P2 instead of P2F if FORM is a variable [ADRREFP true]. ;;12/09/86 - Call P2 instead of P2F if FORM is a LEXICAL-REF. (LET* ((THE-FORM (CONS 'THE-EXPR ARGL)) (OPTIMIZE-SWITCH (EXPR-OPTIMIZE THE-FORM)) (FORM (EXPR-FORM THE-FORM))) (IF (OR (ATOM FORM) (MEMBER (CAR FORM) '(QUOTE LOCAL-REF SELF-REF LEXICAL-REF FUNCTION BREAKOFF-FUNCTION %POP) :TEST #'EQ)) ; special forms handled directly by P2 (P2 FORM DEST) (P2F FORM DEST) ) )) (DEFUN (:PROPERTY PROGN-WITH-DECLARATIONS P2) (ARGL DEST) (LET ((VARS (CAR ARGL))) (P2PROGN (CDR ARGL) DEST))) (DEFPROP PROGN P2PROGN P2) (DEFPROP DONT-OPTIMIZE P2PROGN P2) (DEFUN P2PROGN (ARGL DEST) (P2PROG12N (LENGTH ARGL) DEST ARGL)) (DEFUN (:PROPERTY PROG1 P2) (ARGL DEST) (P2PROG12N 1 DEST ARGL)) (DEFPROP PROG2 P2PROG2 P2) (DEFUN P2PROG2 (ARGL DEST) (P2PROG12N 2 DEST ARGL)) ;Compile a PROGN or PROG2, etc. ARGL is the list of argument expressions. ;N says which arg is to be returned as the value of the PROGN or PROG2 ;(equals the length of ARGL for PROGN, or 2 for PROG2, etc.). (DEFUN P2PROG12N (N DEST ARGL) (PROG ((IDEST DEST)) (WHEN (AND (NOT (EQ DEST 'D-IGNORE)) (< N (LENGTH ARGL))) (SETQ IDEST 'D-PDL)) ;MIGHT COMPILE TEST ON RESULT INDICATORS (SETQ N (1- N)) ;Convert to origin 0. ;; Compile the args before the one whose value we want. (DOTIMES (I N) (P2 (OR (CAR ARGL) '(QUOTE NIL)) 'D-IGNORE) (POP ARGL)) ;; Compile the arg whose value we want. ;; If it's the last arg (this is PROGN), ;; make sure to pass along any multiple value target that the PROGN has, ;; and to report back how many args were actually pushed. (COND ((AND (NULL (CDR ARGL)) M-V-TARGET) (COND ((P2MV (OR (CAR ARGL) '(QUOTE NIL)) IDEST M-V-TARGET) (INCPDLLVL)) ((NUMBERP M-V-TARGET) (MKPDLLVL (+ PDLLVL M-V-TARGET)) (SETQ M-V-TARGET NIL)) (T (INCPDLLVL) ;target was THROW, RETURN or MULTIPLE-VALUE-LIST (SETQ M-V-TARGET NIL)))) ((AND (NULL (CDR ARGL)) BDEST) (P2BRANCH (OR (CAR ARGL) '(QUOTE NIL)) IDEST BDEST) (SETQ BDEST NIL) (WHEN (EQ IDEST 'D-PDL) (INCPDLLVL))) (T (P2 (OR (CAR ARGL) '(QUOTE NIL)) IDEST) (WHEN (EQ IDEST 'D-PDL) (INCPDLLVL)))) (OR (CDR ARGL) (RETURN NIL)) ;; Compile the remaining args. (DOLIST (ARG (CDR ARGL)) (P2 ARG 'D-IGNORE)) (COND ((NOT (EQ IDEST DEST)) (MOVE-RESULT-FROM-PDL DEST)) ((NOT (EQ DEST 'D-IGNORE)) (OUTF '(MOVE D-PDL PDL-POP)))))) ;Make sure it's really in indicators ; if IDEST and DEST both D-PDL (DEF QUOTE-LOAD-TIME-EVAL) ;; P1 wraps one of these around a QUOTE form that contains an ;; EVAL-AT-LOAD-TIME-MARKER in order to prevent optimization. At this point ;; we can just treat it as an ordinary QUOTE. ;; Added 7/7/87 to fix SPR 4918. (DEFUN (:PROPERTY QUOTE-LOAD-TIME-EVAL P2) (ARGL DEST) (P2 (FIRST ARGL) DEST)) (DEFUN PUSH-NILS (COUNT) ;; 9/30/85 DNG - Use P2PUSH-CONSTANT. (DOTIMES (I COUNT) (P2PUSH-CONSTANT (QUOTE NIL)))) ;;; Functions to gobble multiple values. (DEFUN (:PROPERTY MULTIPLE-VALUE-BIND P2) (TAIL DEST) ;; 01/14/86 DNG - Move the binding of PDLLVL so that it is restored ;; after the call to P2PBIND. This is so that a RETURN out of ;; the body won't pop values that have already been %POPped. ;; 1/22/86 DNG - Fix to unbind special variables. ;; 8/19/86 DNG - Use PUSH-NILS instead of a DO loop generating MOVEs. ;; 5/03/89 DNG - Modified to use P2SB1 instead of P2PBIND. (LET ((BOUNDVARS (CAR TAIL)) (NBINDS 0)) (LET ((PDLLVL PDLLVL) (MVTARGET (LENGTH BOUNDVARS)) (VARS (SECOND TAIL)) (MVFORM (FOURTH TAIL))) ;; Compile the form to leave N things on the stack. ;; If it fails to do so, then it left only one, so push the other N-1. (MKPDLLVL (+ PDLLVL MVTARGET)) (AND (P2MV MVFORM 'D-PDL MVTARGET) (PUSH-NILS (- MVTARGET 1))) ;; Now pop them off, binding the variables to them. ;; Note that the vlist contains the variables ;; in the original order, ;; each with an initialization of (%POP). (DOLIST (HOME (REVERSE BOUNDVARS)) (IF (OR (NULL HOME) (NOT (DEBUG-ASSERT (NEQ (VAR-KIND HOME) 'FEF-ARG-DELETED))) (NOT (DEBUG-ASSERT (NEQ (VAR-INIT-KIND HOME) 'FEF-INI-SETQ)))) (OUT-AUX 'POP-PDL 1) ; just pop the value off (WHEN (P2SB1 HOME) ; assign it to the variable (INCF NBINDS))))) (LET ((VARS (THIRD TAIL)) (BODY (CDDDDR TAIL)) (PROGDESCS PROGDESCS)) (UNLESS (ZEROP NBINDS) ;; Push a dummy progdesc so that GOs exiting this form can unbind our specials. (PUSH (MAKE-PROGDESC NAME '(LET) PDL-LEVEL PDLLVL NBINDS NBINDS) PROGDESCS)) (P2PROG12N (LENGTH BODY) DEST BODY)) (UNBIND DEST NBINDS))) (DEFUN (:PROPERTY NTH-VALUE P2) (TAIL DEST) ;; 10/17/86 DNG - Use NTH instead of ELT so args are not evaled in reverse order. (IF (AND (QUOTEP (CAR TAIL)) (TYPEP (CADR (CAR TAIL)) '(INTEGER 0))) (IF (ZEROP (CADR (CAR TAIL))) (P2 `(VALUES ,(CADR TAIL)) DEST) (PROGN (P2MV (CADR TAIL) 'D-PDL (1+ (CADR (CAR TAIL)))) (POPPDL 1 (CADR (CAR TAIL))) (MOVE-RESULT-FROM-PDL DEST))) (P2 `(NTH ,(CAR TAIL) (MULTIPLE-VALUE-LIST ,(CADR TAIL))) DEST))) (DEFPROP MULTIPLE-VALUE P2MULTIPLE-VALUE P2) (DEFUN P2MULTIPLE-VALUE (TAIL DEST) ;; 1/29/86 CLM - Modified for Rel.3 so that if DEST equals d-ignore and ;; the first element in variable list is nil, a complex-call-to push ;; will be generated instead of a c-c-to-inds (LET* ((VARIABLES (CAR TAIL)) (DEST1 'D-PDL)) (BLOCK NIL (COND ((P2MV (CADR TAIL) DEST1 (LENGTH VARIABLES)) ; NIL if it actually pushes N values. ;; It didn't push them. Set the other variables to NIL. (DOLIST (VAR (CDR VARIABLES)) (AND VAR (P2SETQ-1 VAR '(QUOTE NIL) 'D-IGNORE))) ;; If the single value was discarded, nothing remains to be done. (AND (EQ DEST1 'D-IGNORE) (RETURN NIL))) (T ;; It really did push N values on the stack. Pop all but the first off. (DOLIST (VAR (REVERSE (CDR VARIABLES))) (IF VAR (MOVEM-AND-MOVE-TO-DEST VAR 'D-IGNORE) (OUTF '(MOVE D-IGNORE PDL-POP)))))) ;; Now there is only one thing on the stack, which is the value ;; of the first variable, and the value to be returned by ;; the call to MULTIPLE-VALUE. (IF (CAR VARIABLES) (MOVEM-AND-MOVE-TO-DEST (CAR VARIABLES) DEST) (MOVE-RESULT-FROM-PDL DEST)) NIL))) (DEFPROP MULTIPLE-VALUE-PROG1 P2MULTIPLE-VALUE-PROG1 P2) (DEFUN P2MULTIPLE-VALUE-PROG1 (TAIL DEST) ;; 4/21/86 CLM - Fix to prevent superfluous RETURN instruction ;; from being generated. ;; 10/08/86 DNG - Fix to not use RETURN-N when only a single value pushed. ;; 01/16/87 CLM - Fix to handle unbinding of special variables if within a ;; CATCH. (LET (SINGLE-VALUE-RETURN) (COND ((OR (EQ DEST 'D-RETURN) (EQ M-V-TARGET 'RETURN-CATCH)) (SETQ SINGLE-VALUE-RETURN (P2MV (CAR TAIL) 'D-PDL 'RETURN)) (UNLESS SINGLE-VALUE-RETURN (SETQ M-V-TARGET NIL)) ) (M-V-TARGET (UNLESS (P2MV (CAR TAIL) DEST M-V-TARGET) (SETQ M-V-TARGET nil))) (T (P2 (CAR TAIL) (IF (EQ DEST 'D-LAST) 'D-PDL DEST)))) (DOLIST (FORM (CDR TAIL)) (P2 FORM 'D-IGNORE)) (IF (AND (EQ DEST 'D-RETURN) (NOT SINGLE-VALUE-RETURN)) (OUT-AUX 'RETURN-N) (WHEN (MEMBER DEST '(D-RETURN D-LAST) :TEST #'EQ) (MOVE-RESULT-FROM-PDL DEST))))) ;; Note that we make no provision for the possibility ;; than anything might want to optimize being compiled ;; for multiple-value-list by storing the list directly ;; to a destination other than D-PDL. (DEFPROP MULTIPLE-VALUE-LIST P2MULTIPLE-VALUE-LIST P2) (DEFUN P2MULTIPLE-VALUE-LIST (TAIL DEST) ;; 2/14/86 DNG - Use OUTI instead of OUTF for NCONS. (IF (P2MV (CAR TAIL) 'D-PDL 'MULTIPLE-VALUE-LIST) (NO-D-RETURN (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'NCONS)))) (MOVE-RESULT-FROM-PDL DEST))) (DEFPROP MULTIPLE-VALUE-CALL P2MULTIPLE-VALUE-CALL P2) (DEFUN P2MULTIPLE-VALUE-CALL (FORM DEST) ;; 9/05/86 CLM - Original. If there still is a multiple-value-call ;; at this point, then there is only a single form in ;; the arglist. Call P2MV with this form and a DEST ;; D-PDL and an M-V-TARGET of RETURN so that the values ;; returned will be pushed on the stack followed by the ;; count. This sets things up for a CALL-N to the function. ;; 10/01/86 CLM - Use a CALL-1 instruction for cases where there is only a ;; single value returned from P2MV. ;; 10/20/86 CLM - Undo the previous change; the conversion to CALL-1 is now ;; done in PEEP. ;; 07/22/87 CLM - Fix to handle cases where multiple values are expected ;; to be returned by the function. Use %CALL to generate ;; the complex-call instruction. (LET (SINGLE-VALUE-RETURN) (SETQ SINGLE-VALUE-RETURN (P2MV (SECOND FORM) 'D-PDL 'RETURN)) (WHEN SINGLE-VALUE-RETURN (P2PUSH-CONSTANT 1)) (IF M-V-TARGET (SETQ M-V-TARGET ;;signal for multiple values (P2MV `(%CALL ,(CAR FORM) (%POP)) DEST M-V-TARGET)) (OUTI (LIST 'CALL-N DEST (P2-SOURCE (CAR FORM) 'D-PDL))) ) )) (DEFPROP *THROW P2THROW P2) (DEFPROP THROW P2THROW P2) (DEFUN P2THROW (TAIL IGNORE) ;; 10/28/85 CLM - Changed to generate Rel.3 aux-ops %THROW and ;; %THROW-N instead of misc-op *THROW. ;; 2/07/86 CLM - Modified to emit a %close-catch if the throw is ;; from within the undo forms of an unwind protect. ;; 11/17/86 CLM - Increment the pdllvl after pushing the tag so that we ;; know it's been pushed in case we exit before the throw ;; and have to pop the tag off the stack. (P2PUSH (CAR TAIL)) ;Compute and push the tag. (INCPDLLVL) (LET (SINGLE-VALUE-RETURN) (SETQ SINGLE-VALUE-RETURN (P2MV (CADR TAIL) 'D-PDL 'THROW)) (IF SINGLE-VALUE-RETURN (OUTI '(AUX %THROW)) (OUTI '(AUX %THROW-N)))) (SETQ DROPTHRU NIL)) (DEF MULTIPLE-VALUE-PUSH) (DEFPROP MULTIPLE-VALUE-PUSH ("E NUMBER-OF-VALUES &EVAL EXPRESSION) ARGLIST) (DEFUN (:PROPERTY MULTIPLE-VALUE-PUSH P2) (TAIL DEST) (DECLARE (IGNORE DEST)) (WHEN (P2MV (CADR TAIL) 'D-PDL (CAR TAIL)) ; NIL if it actually pushes N values. ;; It didn't push them. Push extra NILs. (PUSH-NILS (1- (CAR TAIL)))) (MKPDLLVL (+ PDLLVL (CAR TAIL)))) ;Functions to generate multiple values. (DEFPROP VALUES P2VALUES P2) (DEFUN P2VALUES (ARGL DEST) ;; 8/21/85 - Use OUT-AUX. ;; 9/07/85 - Use main-op form of RETURN-2 and RETURN-3. ;; 9/25/85 - AUX RETURN-0 etc. ;; 10/28/85 - CLM Changed to generate Rel.3 aux-ops %THROW ;; and %THROW-N instead of misc-ops THROW-N and *THROW. ;; 12/18/85 - CLM For rel. 3, modified so that when M-V-TARGET equals ;; RETURN the RETURN-N-KEEP-CONTROL misc-op is no longer ;; emitted; values and count are pushed on the stack. ;; 2/17/86 DNG - Use LAP-VALUE instead of GET-FOR-TARGET. ;; 7/16/86 CLM - No longer generate a throw here; this was causing too ;; many throws when there was an intervening CATCH between ;; the THROW and its target. ALSO , when M-V-TARGET is RETURN ;; and only one item is in the argl, do not set M-V-TARGET to ;; nil; this signals that a single value is being returned. ;; 9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET. (BLOCK NIL ;; Handle returning from the top level of a function. (WHEN (EQ DEST 'D-RETURN) (LET ((NARGS (LENGTH ARGL))) (WHEN (= NARGS 1) ;; DON'T change this to (P2 ... 'D-RETURN) ;; because we want to make sure to pass only one value. (P2 (CAR ARGL) 'D-PDL) (MOVE-RESULT-FROM-PDL 'D-RETURN) (RETURN)) (COND ((AND (LAP-VALUE 'RETURN-0) (<= NARGS 63)) (ARGLOAD ARGL 'D-PDL) (OUT-AUX 'RETURN-0 NARGS)) ((= NARGS 2) (P2PUSH (FIRST ARGL)) (LET ((ADR (P2-SOURCE (SECOND ARGL) 'D-PDL))) (IF (EQ ADR 'PDL-POP) (OUT-AUX '%RETURN-2) (OUTI `(RETURN-2 0 ,ADR))))) ((= NARGS 3) (P2PUSH (FIRST ARGL)) (P2PUSH (SECOND ARGL)) (LET ((ADR (P2-SOURCE (THIRD ARGL) 'D-PDL))) (IF (EQ ADR 'PDL-POP) (OUT-AUX '%RETURN-3) (OUTI `(RETURN-3 0 ,ADR))))) ((ZEROP NARGS) (P2VALUES-LIST '((QUOTE NIL)) DEST)) (T (ARGLOAD ARGL 'D-PDL) (P2PUSH-CONSTANT NARGS) (OUT-AUX '%RETURN-N))) (SETQ DROPTHRU NIL) ;Above MISC RETURN instructions return (RETURN NIL))) (COND ((NUMBERP M-V-TARGET) ;; If we want N values on the stack, ;; then eval all the args to return ;; and save exactly N things on the stack. (DO ((VALS ARGL (CDR VALS)) (I 0 (1+ I))) ((AND (NULL VALS) (>= I M-V-TARGET))) (P2 (OR (CAR VALS) '(QUOTE NIL)) (IF (>= I M-V-TARGET) 'D-IGNORE 'D-PDL)))) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (P2 `(LIST . ,ARGL) DEST)) ((EQ M-V-TARGET 'THROW) (DOLIST (ELT ARGL) (P2PUSH ELT)) (UNLESS (= (LENGTH ARGL) 1) (P2PUSH-CONSTANT (LENGTH ARGL)) )) ((MEMBER M-V-TARGET '(RETURN RETURN-CATCH) :TEST #'EQ) (DOLIST (ELT ARGL) (P2PUSH ELT)) (IF (= (LENGTH ARGL) 1) (RETURN) (P2PUSH-CONSTANT (LENGTH ARGL)))) ((NULL M-V-TARGET) (LET ((PDLLVL PDLLVL)) (P2PROG12N 1 DEST ARGL)))) (SETQ M-V-TARGET NIL) NIL)) (DEFPROP VALUES-LIST P2VALUES-LIST P2) (DEFUN P2VALUES-LIST (ARGL DEST) ;; 8/21/85 - For release 3, RETURN-LIST is an Aux-op. ;; 1/16/86 - CLM For release 3, no longer uses the obsolete ;; THROW-SPREAD. Use %SPREAD and then push length ;; of the list on the stack. ;; 1/20/86 - CLM For release 3, no longer uses the obsolete ;; %SPREAD-N. Call P2ARGC with VALUES-LIST as the ;; function argument. ;; 3/19/86 - CLM When M-V-TARGET equals RETURN, spread the ARGL ;; and set up for a RETURN-N; no longer uses RETURN-SPREAD- ;; KEEP-CONTROL. ;; 9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET. (PROG (ARG) (SETQ ARG (CAR ARGL)) (COND ((EQ DEST 'D-RETURN) (P2PUSH ARG) (OUT-AUX 'RETURN-LIST) (SETQ DROPTHRU NIL)) ((NULL M-V-TARGET) (P2 `(CAR ,ARG) DEST)) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (P2 ARG DEST)) ((EQ M-V-TARGET 'THROW) ;;added 1/16/86 by CLM #+compiler:debug (ASSERT (TRIVIAL-FORM-P ARG) () "A NON-TRIVIAL ARG WAS PASSED TO P2VALUES-LIST") (P2PUSH ARG) (OUT-AUX '%SPREAD) (P2PUSH ARG) (OUTM '(MISC D-PDL LENGTH))) ;STACK IS SET FOR A THROW-N ((MEMBER M-V-TARGET '(RETURN RETURN-CATCH) :TEST #'EQ) #+compiler:debug (ASSERT (TRIVIAL-FORM-P ARG) () "A NON-TRIVIAL ARG WAS PASSED TO P2VALUES-LIST") (P2PUSH ARG) (OUT-AUX '%SPREAD) (P2PUSH ARG) (OUTM '(MISC D-PDL LENGTH))) ;STACK SET FOR A RETURN-N ((NUMBERP M-V-TARGET) ;;added 1/20/86 by CLM (P2ARGC NIL ARGL NIL DEST 'VALUES-LIST) )) (SETQ M-V-TARGET NIL))) (DEFUN (:PROPERTY UNWIND-PROTECT P2) (FORMS DEST) ;; 11/17/85 CLM - MODIFIED FOR REL. 3. NOW EMITS AUX-OPS ;; %OPEN-CATCH, %OPEN-CATCH-MULTIPLE-VALUE ;; AND %CLOSE-CATCH INSTEAD OF FORMER MISC-OPS ;; TO CREATE AND THEN REMOVE A CATCH BLOCK. ;; 12/05/85 CLM - MODIFIED FOR REL.3 TO HANDLE CASES WHERE ;; M-V-TARGET EQUALS 'THROW, 'RETURN OR 'MULTIPLE- ;; VALUE-LIST, AND THOSE CASES WHERE DEST EQUALS ;; 'D-RETURN. ;; 1/30/86 CLM - For Rel.3, modified to handle cases where there ;; is a return from within an unwind-protect. Cleanup ;; forms are now handled as a subroutine using the ;; LONG-PUSHJ and POPJ instructions. ;; 2/05/86 CLM - An addendum to the above modification. This handles ;; returns from within the cleanup-forms, and has the ;; restart-pc point to a pushj to the undo-forms. ;; 4/21/86 CLM - If DEST equals D-IGNORE then instead of an %open-catch ;; generate an %open-catch-multiple-value instruction with ;; an argument of 0 to indicate no values are expected. ;; 5/07/86 CLM - In the case where only a single value is to be returned, ;; do a multiple-value return with 1 as the number values. ;; Also, the catch-block is now 5 words long. ;; 5/29/86 CLM - Use the constant CATCH-BLOCK-SIZE instead of the number 5. ;; 6/20/86 CLM - Add special handling for an M-V-TARGET of MULTIPLE-VALUE-LIST. ;; Also, fix to reset PDLLVL after the clean-up forms, instead ;; of before. This was causing problems when there was a return ;; from within the clean-up forms ;; 7/15/86 CLM - Add more special handling for cases where multiple-values are ;; expected, but only a single value is generated. ;; 9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET. ;; 11/17/86 CLM - Changed to handle the new microcode scheme for Unwind-protects. ;; There are now separate mcr funtions to open and close an unwind- ;; protects. We now also take special note of the pdllvl upon ;; entry to the undo forms to handle exits from them. ;; 5/02/88 CLM - Fixed to reset the indicators at the end of the unwind-protect. ;; They were being affected by the cleanup forms, which was causing ;; a problem when the form was within an OR. (spr 7957) (LET ((RESTART-TAG (GENSYM)) (UNDO-TAG (GENSYM)) (EXIT-TAG (GENSYM)) (PDLLVL0 PDLLVL) SINGLE-VALUE-RETURN) (LET ((CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS) (WITHIN-CATCH T)) (P2PUSH-CONSTANT T) ;CATCH-TAG (OUTI1 (LIST 'MOVE 'D-PDL ;RESTART-PC `(QUOTE-VECTOR (TAG ,RESTART-TAG)))) (COND ((EQ DEST 'D-RETURN) (P2PUSH-CONSTANT NIL) (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE))) ((EQ DEST 'D-IGNORE) (P2PUSH-CONSTANT 0) (OUT-AUX '%OPEN-CATCH-MULTIPLE-VALUE)) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (OUTF '(AUX %OPEN-CATCH-MV-LIST))) ((OR (EQ M-V-TARGET 'THROW) (EQ M-V-TARGET 'RETURN) (EQ M-V-TARGET 'RETURN-CATCH)) (P2PUSH-CONSTANT NIL) (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE))) ((NUMBERP M-V-TARGET) (P2PUSH-CONSTANT M-V-TARGET) (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE))) (T (OUTF '(AUX %OPEN-CATCH)))) ;;This causes a problem in the new scheme, so it has been ;;removed. So far its removal has caused no problems. #|(COND ((NULL M-V-TARGET)) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (INCPDLLVL)) ((NUMBERP M-V-TARGET) (MKPDLLVL (+ PDLLVL M-V-TARGET)))) |# (PUSH (LIST PDLLVL 'UNWIND-PROTECT UNDO-TAG) CALL-BLOCK-PDL-LEVELS) (MKPDLLVL (+ CATCH-BLOCK-SIZE PDLLVL)) ;words of call block (COND ((EQ DEST 'D-RETURN) (SETQ SINGLE-VALUE-RETURN (P2MV (CAR FORMS) 'D-PDL 'RETURN))) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (WHEN (P2MV (CAR FORMS) 'D-PDL M-V-TARGET) (OUTI '(MISC D-PDL NCONS)) ) ;must convert a single value into a list ) (M-V-TARGET (SETQ SINGLE-VALUE-RETURN (P2MV (CAR FORMS) (IF (EQ DEST 'D-IGNORE) DEST 'D-PDL) (IF (EQ M-V-TARGET 'RETURN-CATCH) 'RETURN M-V-TARGET)))) (T (P2 (CAR FORMS) (IF (EQ DEST 'D-IGNORE) DEST 'D-PDL)))) (SETQ DROPTHRU T) (WHEN SINGLE-VALUE-RETURN ;handle all returns as a form of mv-return (IF (NUMBERP M-V-TARGET) (DOTIMES (I (1- M-V-TARGET)) (P2PUSH-CONSTANT (QUOTE NIL)) (INCPDLLVL)) (P2PUSH-CONSTANT 1))) (SETQ M-V-TARGET NIL) ;;the restart-pc now points to the %close-catch-unwind-protect (OUTF `(RESTART-TAG ,RESTART-TAG)) (OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT) (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE)) (OUTB `(BRANCH PUSHJ NIL NIL ,UNDO-TAG)) (IF (EQ DEST 'D-RETURN) (PROGN (OUT-AUX '%UNWIND-PROTECT-CONTINUE) (OUT-AUX 'RETURN-N) (SETQ DROPTHRU NIL)) (PROGN (OUT-AUX '%UNWIND-PROTECT-CONTINUE) (UNLESS (EQ DEST 'D-IGNORE) (WHEN (EQ DEST 'D-PDL) (OUTI '(MOVE D-PDL PDL-POP))) ;;make sure the indicators are set correctly (MOVE-RESULT-FROM-PDL DEST)))) (OUTB `(BRANCH ALWAYS NIL NIL ,EXIT-TAG)) (SETQ DROPTHRU T) (OUTF UNDO-TAG) ;;add a tag to call-block-pdl-levels to indicate ;;you are in the undo forms (NCONC (CAR CALL-BLOCK-PDL-LEVELS) '(UNDO)) ;;also now need to keep track of the pdllvl of the ;;undo forms so that can pop any garbage off stack before ;;doing an %unwind-protect-cleanup if there is some type of ;;return out of the undo forms. This is not necessary if the ;;unwind-protect is at top level. (WHEN PROGDESCS (SETF (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS)) (CONS PDLLVL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS))))) (INCPDLLVL) ;;inc for the restart-macro-pc pushed on the stack by long-pushj (DOLIST (FORM (CDR FORMS)) ;cleanup forms (P2 FORM 'D-IGNORE)) (OUT-AUX 'POPJ) (SETQ DROPTHRU NIL) (OUTTAG EXIT-TAG) ;;why does it reset the pdllvl to the original level? ;;what about the values left on the stack ;;i think because this hasn't broken anything it would ;;indicate that it doesn't matter (SETQ PDLLVL PDLLVL0) ))) (DEFUN (:PROPERTY %MAKE-EXPLICIT-STACK-LIST P2) (FORMS DEST) (ARGLOAD FORMS 'D-PDL) (P2PUSH-CONSTANT (LENGTH FORMS)) (OUTI `(MISC ,DEST %MAKE-EXPLICIT-STACK-LIST))) (DEFUN (:PROPERTY %MAKE-EXPLICIT-STACK-LIST* P2) (FORMS DEST) (ARGLOAD FORMS 'D-PDL) (P2PUSH-CONSTANT (LENGTH FORMS)) (OUTI `(MISC ,DEST %MAKE-EXPLICIT-STACK-LIST*))) (SYS:DEFPRINT %LET 1) (SYS:DEFPRINT %LET* 1) (SYS:DEFPRINT %LET-HACK 2) (DEFUN (:PROPERTY %LET* P2) (ARGL DEST) ;; 7/15/86 DNG - Add binding of CLOSURE-DISCONNECT-OFFSETS and LEXICAL-CLOSURE-COUNT. ;; 4/05/89 DNG - Don't need to bind CLOSURE-DISCONNECT-OFFSETS anymore. ;; 4/11/89 DNG - Remove binding of LEXICAL-CLOSURE-COUNT. [SPR 9596] ;; 4/26/89 DNG - Original handler for %LET* adapted from old LET* handler. (DESTRUCTURING-BIND ((BOUNDVARS NEWVARS VARS &REST IGNORE) &REST IGNORE) ARGL (DECLARE (IGNORE NEWVARS)) (LET ((KEEP-CURRENT-FRAME KEEP-CURRENT-FRAME)) (P2LETX (P2-S-BIND BOUNDVARS) ARGL DEST)))) (DEFUN (:PROPERTY %LET P2) (ARGL DEST) ;; 7/07/86 DNG - Use same handler for LET and LET-FOR-LAMBDA. ;; 7/15/86 DNG - Add binding of CLOSURE-DISCONNECT-OFFSETS and LEXICAL-CLOSURE-COUNT. ;; 4/05/89 DNG - Don't need to bind CLOSURE-DISCONNECT-OFFSETS anymore. ;; 4/11/89 DNG - Remove binding of LEXICAL-CLOSURE-COUNT. [SPR 9596] ;; 4/26/89 DNG - Original version adapted from old P2LET. (DESTRUCTURING-BIND ((BOUNDVARS NEWVARS VARS &REST IGNORE) &REST IGNORE) ARGL (DECLARE (IGNORE NEWVARS)) (LET ((KEEP-CURRENT-FRAME KEEP-CURRENT-FRAME)) (P2LETX (P2-P-BIND BOUNDVARS) ARGL DEST))) ) ;%LET-HACK is generated by P2LETX in case of lexical closures and WITHIN-CATCH. (DEFUN (:PROPERTY %LET-HACK P2) (ARGL DEST) (DESTRUCTURING-BIND (NBINDS &REST ARGS) ARGL (P2LETX NBINDS ARGS DEST T))) ;Compile the body of a LET. The variable binding has already been done ;by P1PBIND or P1SBIND, which returned the number of special bindings made ;which is our argument NBINDS. (DEFUN P2LETX (NBINDS ARGL DEST &OPTIONAL IGNORE-LEXICAL-CLOSURES) ;; 2/06/86 DNG - Move the result value of the LET to its proper destination ;; after any lexical closure disconnect or unshare instructions ;; so that the indicators will be correct for any conditional ;; branch which may follow. [SPR 1075] ;; 5/23/86 CLM - When M-V-TARGET equals RETURN, don't issue unbind instructions. ;; This was causing a problem when returning the result ;; of a CATCH. ;; 7/15/86 DNG - Fix to unshare variables used in lexical closures created ;; at lower levels. ;; 7/16/86 DNG - Fix to use D-PDL instead of D-INDS when a STACK-CLOSURE-UNSHARE ;; is possible so the indicators don't get clobbered. [SPR 2571] ;; 9/02/86 DNG - For VM2, need to unbind specials even when M-V-TARGET is RETURN. ;; 9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET. This value ;; indicates that special variables should not be unbound. ;; 9/13/86 DNG - Modify check for %BIND with multiple values to issue a warning but ;; not do any unbinding when M-V-TARGET is RETURN. ;; 12/15/86 DNG - Save special-pdl-index in a local variable when it can't ;; be kept on the stack because of an unknown number of values. ;; 4/04/89 DNG - When generating an UNWIND-PROTECT, pass (THIRD ARGL) ;; instead of VARS to UNSHARE-STACK-CLOSURE-VARS. [SPR 9239] ;; 4/05/89 DNG - Eliminate obsolete code for VM1. Remove use of DISCONNECT-STACK-CLOSURES. ;; 4/26/89 DNG - Original version of P2LETX adapted from P2LET-INTERNAL. (DESTRUCTURING-BIND ((BOUNDVARS NEWVARS OVARS IBINDP CLOSUREP) &REST BODY) ARGL (DECLARE (IGNORE BOUNDVARS)) (IF (AND WITHIN-CATCH (NOT IGNORE-LEXICAL-CLOSURES) CLOSUREP) (P2F `(UNWIND-PROTECT (%LET-HACK ,NBINDS . ,ARGL) (UNSHARE-STACK-CLOSURE-VARS ,NEWVARS ,OVARS)) DEST) (LET* ((VARS NEWVARS) (IDEST 'D-PDL) NVALUES M-V-DONE (PROGDESCS PROGDESCS)) ;; Determine the immediate destination of returns in this prog. (WHEN (AND (MEMBER DEST '(D-IGNORE D-INDS D-RETURN) :TEST #'EQ) (NULL M-V-TARGET)) (SETQ IDEST DEST)) ;; If BIND is used within this LET, and it's an internal LET, ;; we must push the specpdl index at entry so we can unbind to it later. (WHEN IBINDP ;**** was (AND IBINDP (NOT (EQ DEST 'D-RETURN))) **** (SETQ KEEP-CURRENT-FRAME T) (OUTM '(MISC D-PDL SPECIAL-PDL-INDEX)) (IF (CONSP IBINDP) ; P1LET has provided a place to save the index (OUTI `(POP 0 ,(P2-DESTINATION IBINDP))) ;; else leave it on the stack. (INCPDLLVL))) ;; Push a dummy progdesc so that GOs exiting this LET can unbind our specials. (PUSH (MAKE-PROGDESC NAME '(LET) PDL-LEVEL PDLLVL NBINDS (IF IBINDP (IF (CONSP IBINDP) (LIST NBINDS IBINDP) (LIST NBINDS)) NBINDS)) PROGDESCS) ;; How many words are we supposed to leave on the stack? (SETQ NVALUES (COND ((NUMBERP M-V-TARGET) M-V-TARGET) ((EQ IDEST 'D-PDL) 1) (T 0))) (UNLESS BODY (SETQ BODY '((QUOTE NIL)))) (DO ((TAIL BODY (CDR TAIL))) ((NULL (CDR TAIL)) (UNLESS (P2MV (CAR TAIL) IDEST M-V-TARGET) (SETQ M-V-DONE T))) (P2 (CAR TAIL) 'D-IGNORE)) (UNLESS M-V-DONE (SETQ NVALUES 1)) ;; If this is a top-level PROG, we just went to D-RETURN, so we are done. (UNLESS (EQ DEST 'D-RETURN) ;; Unbind any locals that need to be unbound. (UNLESS IGNORE-LEXICAL-CLOSURES (LET ((CLOBBERED-INDICATORS NIL)) (WHEN (AND TAGOUT (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES *CURRENT-COMPILAND*)) (P2 `(UNSHARE-STACK-CLOSURE-VARS ,VARS ,OVARS) 'D-IGNORE) (SETQ CLOBBERED-INDICATORS T)) )) ;; Unbind any specials ;; 5/23/86 (UNLESS (EQ M-V-TARGET 'RETURN-CATCH) (BLOCK UNBIND (COND ((NULL IBINDP)) ((CONSP IBINDP) (P2PUSH IBINDP) (OUTPUT-UNBIND-TO-INDEX 0)) (T (UNLESS (OR (NULL M-V-TARGET) (NUMBERP M-V-TARGET)) (IF (EQ M-V-TARGET 'RETURN) (PROGN (WARN 'LET-INTERNAL :IMPLAUSIBLE "Warning: %BIND within form producing unknown number of values will not be unbound until returning from the function.") (RETURN-FROM UNBIND)) (WARN 'let-internal :IMPLEMENTATION-LIMIT "The use of %BIND within a form that produces an unknown number of values is currently unsupported"))) (OUTPUT-UNBIND-TO-INDEX NVALUES))) (UNBIND IDEST NBINDS) )) ;; Dispose of our value. (AND (NEQ DEST IDEST) (NULL M-V-TARGET) (MOVE-RESULT-FROM-PDL DEST)) ;; If we produced multiple values, say we did. (WHEN M-V-DONE (SETQ M-V-TARGET NIL))))))) (DEFUN (:PROPERTY UNSHARE-STACK-CLOSURE-VARS P2) (ARGL IGNORE) ;; 7/12/85 - Unshare only when there is a possibility of looping ;; back and binding the same variables to new values. ;; 1/09/85 - For rel3, use LEXICAL-UNSHARE instead of STACK-CLOSURE-UNSHARE. ;; 2/21/86 - Use LEXICAL-UNSHARE-ALL instruction. ;; 7/07/86 - Obtain VARIABLES-USED-IN-LEXICAL-CLOSURES from *CURRENT-COMPILAND*. ;; 11/19/86 - Pop deleted variables off OVARS so that the loop termination test ;; (EQ VS OVARS) works properly -- they won't be in VARS if the LET ;; that created them was completly optimized away. ;; 6/01/87 - Fix to not try to unshare a variable that has been deleted. [SPR 5599,5602] ;; 6/29/87 - Don't try to unshare a phantom variable. [SPR 5719]. ;; Add CERROR check on POSITION result. (WHEN TAGOUT ; may be within a loop (LET ((VARS (CAR ARGL)) (OVARS (CADR ARGL)) (UNSHARE-VARS NIL)) (LOOP WHILE (EQ (VAR-KIND (FIRST OVARS)) 'FEF-ARG-DELETED) DO (POP OVARS)) (DO ((VS VARS (CDR VS))) ((OR (EQ VS OVARS) (NULL VS)) (DEBUG-ASSERT (EQ VS OVARS))) (LET ((V (CAR VS))) (WHEN (AND (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V) :TEST #'EQ) (NOT (EQ (VAR-KIND V) 'FEF-ARG-DELETED)) (NOT (MEMBER 'FEF-ARG-NO-UNSHARE (VAR-MISC V))) ; from EXTEND-LOCAL-VARIABLES ) (PUSH V UNSHARE-VARS)))) (UNLESS (NULL UNSHARE-VARS) (LET (( VARIABLES-USED-IN-LEXICAL-CLOSURES (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES *CURRENT-COMPILAND*) )) (DECLARE (UNSPECIAL VARIABLES-USED-IN-LEXICAL-CLOSURES) (TYPE LIST VARIABLES-USED-IN-LEXICAL-CLOSURES)) (IF (= (LENGTH UNSHARE-VARS) (LENGTH VARIABLES-USED-IN-LEXICAL-CLOSURES)) (OUTI '(AUX LEXICAL-UNSHARE-ALL)) (DOLIST (V UNSHARE-VARS) (LET ((INDEX (POSITION V (THE LIST VARIABLES-USED-IN-LEXICAL-CLOSURES) :TEST #'EQ))) (IF (NULL INDEX) (CERROR CONTINUE-MESSAGE "Compiler bug; can't UNSHARE variable ~S." (VAR-NAME V)) (OUTI `(LEXICAL-UNSHARE ,INDEX))))))))))) ;Compile a BLOCK. ;A BLOCK has no user-defined GOTAGS, but it does have one tag at this level: its rettag. (DEFPROP BLOCK P2BLOCK P2) (DEFUN P2BLOCK (ARGL DEST &OPTIONAL BIND-RETPROGDESC D-INDS-LOSES) ;; 7/03/86 DNG - Eliminate binding of RETPROGDESC since it is now handled in pass 1. ;; 10/18/86 DNG - RETTAG is now a structure instead of a symbol; don't need GOTAGS anymore. (DECLARE (IGNORE BIND-RETPROGDESC)) ; no longer used (LET* ((MYGOTAGS (CAR ARGL)) (MYPROGDESC (CADR ARGL)) (BDY (CDDR ARGL)) (RETTAG (PROGDESC-RETTAG MYPROGDESC)) (PROGDESCS (CONS MYPROGDESC PROGDESCS)) ) (PROG (IDEST NVALUES) ;; Determine the immediate destination of returns in this prog. (SETQ IDEST 'D-PDL) (AND (MEMBER DEST '(D-IGNORE D-INDS D-RETURN) :TEST #'EQ) (NOT (AND (EQ DEST 'D-INDS) D-INDS-LOSES)) (NULL M-V-TARGET) (SETQ IDEST DEST)) ;; How many words are we supposed to leave on the stack? (SETQ NVALUES (COND ((NUMBERP M-V-TARGET) M-V-TARGET) ((EQ IDEST 'D-PDL) 1) (T 0))) (SETF (PROGDESC-IDEST MYPROGDESC) IDEST) (SETF (PROGDESC-M-V-TARGET MYPROGDESC) M-V-TARGET) (SETF (PROGDESC-PDL-LEVEL MYPROGDESC) PDLLVL) (SETF (PROGDESC-NBINDS MYPROGDESC) 0) ;; Set the GOTAG-PDL-LEVEL of each the rettag. ;; MYGOTAGS contains the RETTAG and nothing else. (SETF (GOTAG-PROGDESC (CAR MYGOTAGS)) (CAR PROGDESCS)) (SETF (GOTAG-PDL-LEVEL (CAR MYGOTAGS)) (+ PDLLVL NVALUES)) ;; Generate code for the body. (IF (NULL BDY) (P2RETURN-FROM `(,MYPROGDESC (QUOTE NIL)) 'D-IGNORE) (DO ((TAIL BDY (CDR TAIL))) ((NULL (CDR TAIL)) (P2RETURN-FROM (LIST MYPROGDESC (CAR TAIL)) 'D-IGNORE)) (P2 (CAR TAIL) 'D-IGNORE))) ;; If this is a top-level BLOCK, we just went to D-RETURN, ;; and nobody will use the RETTAG, so we are done. (AND (EQ DEST 'D-RETURN) (RETURN NIL)) ;; Otherwise, this is where RETURNs jump to. (SETQ PDLLVL (GOTAG-PDL-LEVEL (CAR MYGOTAGS))) (OUTTAG (GOTAG-PROG-TAG RETTAG)) ;; Store away the value if ;; it is not supposed to be left on the stack. (AND (NEQ DEST IDEST) (NULL M-V-TARGET) (MOVE-RESULT-FROM-PDL DEST)) ;; If we were supposed to produce multiple values, we did. (SETQ M-V-TARGET NIL)))) ;; This differs from block only when DEST is D-INDS. ;; In that case, this one compiles the value to the PDL, ;; then moves it to D-INDS after popping off any excess pdl words ;; underneath it. BLOCK would compile the value direct to D-INDS, ;; which loses if words must be popped off the stack on falling thru. ;; However, that is something that cannot happen for user BLOCKs. ;; It can happen only for the weird BLOCK body that WITH-STACK-LIST generates. (DEFUN (:PROPERTY BLOCK-FOR-WITH-STACK-LIST P2) (ARGL DEST) (LET ((KEEP-CURRENT-FRAME T)) (P2BLOCK ARGL DEST NIL T))) (DEFUN (:PROPERTY BLOCK-FOR-PROG P2) (ARGL DEST) (P2BLOCK ARGL DEST T)) ;;; RETURN processing -- ;;; pass 1 has changed all varieties of RETURN to (RETURN-FROM progdesc value) ;;; (DEFPROP RETURN-FROM P2RETURN-FROM P2) (DEFUN P2RETURN-FROM (ARGL IGNORE) ;; 1/30/86 CLM - For Rel.3, modified to handle cases where there is a ;; return from within a CATCH or an UNWIND-PROTECT. ;; 2/05/86 CLM - An addendum to the above modification. This handles ;; returns from within the undo forms of unwind-protect's. ;; 2/12/86 CLM - Bind pdllvl to itself upon entry. ;; 2/12/86 DNG - Decrement PDLLVL and NPOPS by 4 for each %CLOSE-CATCH. ;; 2/14/86 DNG - Use OUTI instead of OUTF for NCONS. ;; 3/11/86 CLM - Added special handling for when mvtarget equals return. ;; 5/07/86 CLM - If mvtarget equals RETURN and a single value is being ;; returned, push 1 on the stack to set up for a RETURN-N. ;; 7/16/86 CLM - Use the global variable CATCH-BLOCK-SIZE. ;; 8/28/86 CLM - Fix so that if RPDESC is null, just return from the function ;; 9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET. ;; 10/18/86 DNG - RETTAG is now a structure instead of a symbol. ;; 11/17/86 CLM - Changed to handle new UNWIND-PROTECT's. ;; 11/24/86 CLM - Fix so that a return from a block generated within the undo forms is ;; not treated as a return from the undo forms. (LET ((RPDESC (FIRST ARGL)) ; prog descriptor to return from. (ARG (SECOND ARGL)) ; value to be returned IPROGDEST MVTARGET SINGLE-VALUE-RETURN NVALUES (PDLLVL PDLLVL) (CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS)) (IF (NULL RPDESC) ;; Only get here in case of an error which has already ;; been reported in pass 1. Just return from the function. (SETQ IPROGDEST 'D-RETURN) ;; Else get info for the referenced block. (PROGN (SETQ IPROGDEST (PROGDESC-IDEST RPDESC)) (SETQ MVTARGET (PROGDESC-M-V-TARGET RPDESC)) )) ;; If going to throw values, things expect tag on top of stack. So copy it to there. (WHEN (EQ MVTARGET 'THROW) (UNLESS (= PDLLVL (PROGDESC-PDL-LEVEL RPDESC)) (P2PUSH-CONSTANT (- PDLLVL (PROGDESC-PDL-LEVEL RPDESC))) (OUTI '(MISC D-PDL PDL-WORD)) (INCPDLLVL))) ;; Compile the arg with same destination and m-v-target ;; that the PROG we are returning from had. ;;If there is a return from within an unwind-protect or a catch, ;;handle it as follows. (COND ((OR (AND RPDESC (EQ IPROGDEST 'D-RETURN) (NOT (NULL CALL-BLOCK-PDL-LEVELS)) (<= (PROGDESC-PDL-LEVEL RPDESC) (IF (CONSP (CAR CALL-BLOCK-PDL-LEVELS)) (CAAR CALL-BLOCK-PDL-LEVELS) (CAR CALL-BLOCK-PDL-LEVELS)))) (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ)) (LET ((UNDO-PDL-LEVEL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS)))) ;;return-catch prevents P2LET-INTERNAL from trying to unbind ;;special variables. ;; ;;new unwind-protect scheme - if within the undo forms must ;;do an unwind-protect-cleanup before the returned form is ;;compiled. This requires cleaning off the stack so that ;;the unwind-protect-cleanup works properly. ;;UNDO-PDL-LEVEL is a list of all undo pdlplvl's processed so far. (WHEN (AND (CONSP (CAR CALL-BLOCK-PDL-LEVELS)) (EQ (CADAR CALL-BLOCK-PDL-LEVELS) 'UNWIND-PROTECT) (EQ (CAR (LAST (CAR CALL-BLOCK-PDL-LEVELS))) 'UNDO) UNDO-PDL-LEVEL) (OUT-AUX 'POP-PDL (- PDLLVL (CAR UNDO-PDL-LEVEL))) (OUT-AUX '%UNWIND-PROTECT-CLEANUP) (POP CALL-BLOCK-PDL-LEVELS) (DECF PDLLVL (- PDLLVL (CAR UNDO-PDL-LEVEL))) (POP UNDO-PDL-LEVEL)) (SETQ SINGLE-VALUE-RETURN (P2MV ARG 'D-PDL (IF (EQ MVTARGET 'RETURN) MVTARGET 'RETURN-CATCH))) (DO ((L CALL-BLOCK-PDL-LEVELS (CDR L))) ((OR (NULL L) (< (IF (CONSP (CAR L)) (CAAR L) (CAR L)) (PROGDESC-PDL-LEVEL RPDESC)))) ;;If within an unwind-protect, ;;jump to the cleanup forms subr ;;unless you're already in the cleanup forms. ;;If you are returning completely out of the funtion, ;;you don't have to worry about the stuff left on the ;;stack by all the intervening %close-catch-unwind-protect's. (IF (AND (CONSP (CAR L)) (EQ (CADAR L) 'UNWIND-PROTECT)) (UNLESS (EQ (CAR (LAST (CAR L))) 'UNDO) (PROGN (OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT) (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE)) (OUTB `(BRANCH PUSHJ NIL NIL ,(CADDAR L))) (OUT-AUX '%UNWIND-PROTECT-CONTINUE) )) (PROGN (OUT-AUX '%CLOSE-CATCH) (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE)))) ) (IF (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ) (PROGN (WHEN SINGLE-VALUE-RETURN ;set up for an ultimate return-n (P2PUSH-CONSTANT 1)) (OUTB `(BRANCH ALWAYS NIL NIL ,(GOTAG-PROG-TAG (PROGDESC-RETTAG RPDESC))))) (PROGN (IF SINGLE-VALUE-RETURN ;;a single value (OUT-AUX '(RETURN 0 PDL-POP)) ;;multiple values (OUT-AUX 'RETURN-N)) (SETQ DROPTHRU NIL)))) ) ;;This is specifically for a return from an undo. As above we are ;;not concerned with items left on the stack by previous unwind-protect ;;closes. This means they will be left on the stack, which may present ;;a problem. ((AND (NOT (NULL CALL-BLOCK-PDL-LEVELS)) (CONSP (CAR CALL-BLOCK-PDL-LEVELS)) (EQ (CADAR CALL-BLOCK-PDL-LEVELS) 'UNWIND-PROTECT) (EQ (CAR (LAST (CAR CALL-BLOCK-PDL-LEVELS))) 'UNDO) (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS))) (LET* ((UNDO-PDL-LEVEL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS))) (PDLLVL-DELTA (- PDLLVL (CAR UNDO-PDL-LEVEL)))) (IF (ZEROP PDLLVL-DELTA) (OUT-AUX 'POP-PDL 1) ;haven't pushed anything on the stack but must pop the restart-macro-pc (OUT-AUX 'POP-PDL PDLLVL-DELTA)) (OUT-AUX '%UNWIND-PROTECT-CLEANUP) (DECF PDLLVL (IF (ZEROP PDLLVL-DELTA) 1 PDLLVL-DELTA)) (SETQ SINGLE-VALUE-RETURN (P2MV ARG IPROGDEST MVTARGET)) (POP CALL-BLOCK-PDL-LEVELS) ;get rid of current one (DO ((L CALL-BLOCK-PDL-LEVELS (CDR L))) ((OR (NULL L) (< (IF (CONSP (CAR L)) (CAAR L) (CAR L)) (PROGDESC-PDL-LEVEL RPDESC)))) ;;if within an unwind-protect, ;;jump to the cleanup forms subr ;;unless you're in the cleanup forms. (IF (AND (CONSP (CAR L)) (EQ (CADAR L) 'UNWIND-PROTECT)) (UNLESS (EQ (CAR (LAST (CAR L))) 'UNDO) (PROGN (OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT) (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE)) (OUTB `(BRANCH PUSHJ NIL NIL ,(CADDAR L))) (OUT-AUX '%UNWIND-PROTECT-CONTINUE) )) (PROGN (OUT-AUX '%CLOSE-CATCH) (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE)))) (POP CALL-BLOCK-PDL-LEVELS) ) ) ) (T (SETQ SINGLE-VALUE-RETURN (P2MV ARG IPROGDEST MVTARGET)) ) ) ;; But, since a PROG has multiple returns, we can't simply ;; pass on to the PROG's caller whether this function did or did not ;; generate those multiple values if desired. ;; If the function failed to, we just have to compensate here. (AND SINGLE-VALUE-RETURN (COND ((NUMBERP MVTARGET) ;; If we wanted N things on the stack, we have only 1, so push N-1 NILs. (PUSH-NILS (- MVTARGET 1))) ((EQ MVTARGET 'MULTIPLE-VALUE-LIST) (OUTI '(MISC D-PDL NCONS))))) (SETQ NVALUES (COND ((NUMBERP MVTARGET) MVTARGET) ((EQ IPROGDEST 'D-PDL) 1) (T 0))) ;; Note how many things we have pushed. (AND (EQ IPROGDEST 'D-PDL) (MKPDLLVL (+ PDLLVL NVALUES))) ;; Jump to the prog's rettag, unless the prog is top-level (to d-return) ;; since in that case the code just compiled will not ever drop through. (OR (EQ IPROGDEST 'D-RETURN) (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ) (OUTBRET (PROGDESC-RETTAG RPDESC) RPDESC NVALUES)))) (DEFPROP TAGBODY P2TAGBODY P2) (DEFUN P2TAGBODY (ARGL PROGDEST) ;; 6/02/86 DNG - Bind TAGOUT to itself so that it indicates whether we ;; are currently within a loop. ;; 10/18/86 DNG - Now need to look up tag in MYGOTAGS before calling GTAG. ;; Don't need GOTAGS anymore. (LET* ((MYGOTAGS (CAR ARGL)) (BODY (CDR ARGL)) (TAGOUT TAGOUT) (MYPROGDESC (GOTAG-PROGDESC (CAR MYGOTAGS))) (PROGDESCS PROGDESCS)) ;; Remember this TAGBODY's general environment. ;; We supply as the supposed block name ;; a list that will not appear as the block name in any RETURN-FROM. ;; So we can have an entry on the PROGDESCS list to record our tags' pdllvl ;; without interfering with RETURN-FROM. (WHEN MYGOTAGS (SETF (PROGDESC-PDL-LEVEL MYPROGDESC) PDLLVL) (PUSH MYPROGDESC PROGDESCS) ;; Set the GOTAG-PDL-LEVEL of each of the tags. (DOLIST (GOTAG MYGOTAGS) (SETF (GOTAG-PDL-LEVEL GOTAG) PDLLVL))) (DOLIST (STMT BODY) (COND ((ATOM STMT) (UNLESS DROPTHRU (OUTF '(NO-DROP-THROUGH))) (SETQ TAGOUT (SETQ DROPTHRU T)) (OUTF (GTAG (ASSOC STMT MYGOTAGS :TEST #'EQUAL)))) (T (P2 STMT 'D-IGNORE)))) (P2 '(QUOTE NIL) PROGDEST))) (DEFPROP GO P2GO P2) (DEFUN P2GO (ARGL IGNORE) ;; 2/12/86 CLM - Bind pdllvl to itself upon entry. ;; 10/18/86 DNG - Error checking is now done in pass 1. (LET ((PDLLVL PDLLVL)) (OUTB1 (CAR ARGL)))) (DEFUN (:PROPERTY GO-HACK P2) (ARGL IGNORE) (OUTB `(BRANCH ALWAYS NIL NIL ,(GOTAG-LAP-TAG (CAR ARGL))))) (DEFUN (:PROPERTY *CATCH P2) (ARGL DEST) ;;10/22/85 - CLM CONVERT CATCHES FROM MISC-OPS TO AUX-OPS. ;;10/30/85 - CLM CHANGED FOR REL.3 TO PREVENT CATCH TAG BEING PUSHED ;; AFTER THE %OPEN-CATCH(-MULTIPLE-VALUE) IS GENERATED. ;;12/05/85 - CLM FOR REL.3 REMOVED ALL REFERENCES TO THE OLD ADI-LIST; ;; NOW HANDLES CASES WHERE M-V-TARGET EQUALS 'THROW, 'RETURN ;; AND 'MULTIPLE-VALUE-LIST OR DEST EQUALS 'D-RETURN. ;;12/05/85 - CLM Modified for Rel.3 - setting the DROPTHRU flag and the PDLLVL. ;; 2/11/86 - CLM Changed to not increment PDLLVL by four for a catch block. This was ;; causing POPPDL to pop too many words. ;; 2/12/86 - CLM Modified last change to do the same thing in another function. ;; This will solve the problem of too many close-catches being generated. ;; 2/14/86 - CLM Fix to prevent extra push-constant being generated. ;; 4/21/86 - CLM If DEST equals D-IGNORE then instead of an %open-catch ;; generate an %open-catch-multiple-value instruction with ;; an argument of 0 to indicate no values are expected. ;; 5/07/86 - CLM The catch block is now 5 words long. ;; 5/21/86 - CLM When compiling for Rel. 2, a catch within a multiple-value-list ;; form was not being closed upon normal exit (i.e., no throw). ;; This caused a problem when the multiple-value-list form was ;; within an unwind-protect. This is a fix for SPR 2257. ;; 5/29/86 - CLM Use the constant CATCH-BLOCK-SIZE instead of a number. ;; 6/06/86 - CLM Fixes the fix for SPR 2257. Also, with an M-V-TARGET of ;; MULTIPLE-VALUE-LIST and a form that returns a single value, ;; ncons the value to create a list; previously only the value ;; was returned, not a list containing the value. ;; 6/20/86 - CLM Add special handling for an M-V-TARGET of MULTIPLE-VALUE-LIST to ;; ensure that a single value will be returned as a list. ;; 7/15/86 - CLM Add more special handling for cases where multiple-values are ;; expected, but only a single value is generated. ;; 7/16/86 - CLM A continuation of the previous fix. This handles cases where ;; a definite number of values is expected and there is a throw. ;; Let the throw microcode handle cases where the number of values ;; returned is less than expected. ;; 9/05/86 - CLM Introduce a new value for M-V-TARGET: RETURN-CATCH. This is used ;; when DEST is D-RETURN, and its purpose is to prevent a possible ;; attempt by P2LET-INTERNAL to unbind special variables, ;; which in this situation, would result in an error. ;; 4/05/89 DNG - Remove obsolete code for VM1. (LET ((INITIAL-PDLLVL PDLLVL) RESTART-PC (CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS) (WITHIN-CATCH T) SINGLE-VALUE-RETURN) ;;CHANGE MADE 10/22/85 BY CLM ;;CHANGE MADE 12/05/85 BY CLM ;;EMIT THE CATCH-TAG, THE RESTART-PC, AND IF A MV CATCH, THE NUMBER OF VALUES (P2 (CAR ARGL) (IF GENERATING-MICRO-COMPILER-INPUT-P 'D-NEXT 'D-PDL)) (OUTI1 (LIST 'MOVE 'D-PDL `(QUOTE-VECTOR (TAG ,(SETQ RESTART-PC (GENSYM)))))) ;RESTART-PC (COND ((EQ DEST 'D-RETURN) (P2PUSH-CONSTANT NIL) (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE))) ((EQ DEST 'D-IGNORE) (P2PUSH-CONSTANT 0) (OUT-AUX '%OPEN-CATCH-MULTIPLE-VALUE)) ((NULL M-V-TARGET) (OUTF '(AUX %OPEN-CATCH))) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (OUTF '(AUX %OPEN-CATCH-MV-LIST))) ((OR (EQ M-V-TARGET 'THROW) (EQ M-V-TARGET 'RETURN) (EQ M-V-TARGET 'RETURN-CATCH)) (P2PUSH-CONSTANT NIL) (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE))) ((NUMBERP M-V-TARGET) (P2PUSH-CONSTANT M-V-TARGET) (OUTF '(AUX %OPEN-CATCH-MULTIPLE-VALUE)))) (PUSH PDLLVL CALL-BLOCK-PDL-LEVELS) (MKPDLLVL (+ PDLLVL CATCH-BLOCK-SIZE)) (COND ((EQ DEST 'D-RETURN) (SETQ SINGLE-VALUE-RETURN (P2MV (CADR ARGL) 'D-PDL 'RETURN-CATCH))) ((NULL M-V-TARGET) (P2 (CADR ARGL) (IF (EQ DEST 'D-IGNORE) DEST 'D-PDL))) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (WHEN (P2MV (CADR ARGL) 'D-PDL M-V-TARGET) (OUTM '(MISC D-PDL NCONS)) ) ;must convert a single value into a list ) ((NUMBERP M-V-TARGET) (SETQ SINGLE-VALUE-RETURN (P2MV (CADR ARGL) (IF (EQ DEST 'D-IGNORE) DEST 'D-PDL) M-V-TARGET)) (WHEN (AND SINGLE-VALUE-RETURN (NULL DROPTHRU)) ;there has been a throw (SETQ SINGLE-VALUE-RETURN NIL))) (T (SETQ SINGLE-VALUE-RETURN (P2MV (CADR ARGL) (IF (EQ DEST 'D-IGNORE) DEST 'D-PDL) M-V-TARGET))) ) ;;for those cases where the body of the catch has ;;produced only a single value (WHEN SINGLE-VALUE-RETURN (IF (NUMBERP M-V-TARGET) (DOTIMES (I (1- M-V-TARGET)) (P2PUSH-CONSTANT (QUOTE NIL)) (INCPDLLVL)) (P2PUSH-CONSTANT 1))) (SETQ DROPTHRU T) (OUTF (LIST 'RESTART-TAG RESTART-PC)) ;;CHANGE MADE 10/22/85 BY CLM ;;CHANGE MADE 12/05/85 BY CLM (IF (EQ DEST 'D-RETURN) (PROGN (OUTI '(AUX %CLOSE-CATCH)) (OUT-AUX 'RETURN-N) (SETQ PDLLVL INITIAL-PDLLVL)) (PROGN (OUTI (LIST 'AUX '%CLOSE-CATCH)) (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE)))) (WHEN (PROG1 (NULL M-V-TARGET) (SETQ M-V-TARGET NIL)) (UNLESS (MEMBER DEST '(D-RETURN D-PDL D-IGNORE) :TEST #'EQ) (MOVE-RESULT-FROM-PDL DEST) (SETQ PDLLVL (1- PDLLVL)))) )) ;Bind a list of variables, computing initializations and binding sequentially. (DEFUN P2-S-BIND (BOUNDVARS) ;; 4/26/89 DNG - Original version of P2-S-BIND replaces P2SBIND. (LET ((NBINDS 0)) ; Number of (internal-aux) special bindings (DOLIST (HOME BOUNDVARS) (UNLESS (EQ (VAR-KIND HOME) 'FEF-ARG-DELETED) (WHEN (P2SB1 HOME) (INCF NBINDS)) (PUSH HOME VARS))) NBINDS)) ;Output code for binding the var VARNAME as specified in its HOME. ;Return T if a BIND-POP or BIND-NIL instruction was output. (DEFUN P2SB1 (HOME) ;; 8/22/85 - Support BIND-CURRENT instruction; set KEEP-CURRENT-FRAME ;; flag when a special variable is bound. ;; 10/30/85 - Change name BINDNIL to BIND-NIL and BINDPOP to BIND-POP; ;; implement use of BIND-T. ;; 12/07/85 - For release 3, FEF-ARG-AUX special variables are not bound on ;; function entry; delete references to FEF-REMOTE. ;; 3/3/89 DNG - Inserted temporary debug check to ensure consistency. This ;; is to make sure that the new optimization in SETQ-OPT doesn't do ;; something wrong. ;; 4/26/89 DNG - Remove references to 'FEF-INI-OPT-SA, which is no longer used. ;; 4/26/89 DNG - Original version of P2SB1 adapted from P2LMB. (LET (INTCODE INITFORM KIND) (BLOCK NIL (SETQ INTCODE (VAR-INIT HOME)) ;; If this variable's binding is fully taken care of by function entry, ;; we have nothing to do here. (UNLESS (EQ (CAR INTCODE) 'FEF-INI-COMP-C) (RETURN NIL)) (SETQ INITFORM (SECOND INTCODE)) ;; Detect and handle internal special bound variables. (SETQ KIND (VAR-KIND HOME)) (WHEN (EQ (VAR-TYPE HOME) 'FEF-SPECIAL) ;; Output BIND-NIL, or push value and BIND-POP. (COND ((MEMBER INITFORM '(NIL (QUOTE NIL)) :TEST #'EQUAL) (OUTIV 'BIND-NIL HOME)) ((AND (EQ INITFORM (VAR-NAME HOME)) ; bind to itself (INSTRUCTION-EXISTS-P 'BIND-CURRENT)) (OUTIV 'BIND-CURRENT HOME)) ((AND (EQUAL INITFORM ''T) (INSTRUCTION-EXISTS-P 'BIND-T)) (OUTIV 'BIND-T HOME)) (T (P2PUSH INITFORM) (OUTIV 'BIND-POP HOME))) (SETQ KEEP-CURRENT-FRAME T) (RETURN T)) ;; If variable deleted by function LET-OPT, do nothing. (WHEN (EQ KIND 'FEF-ARG-DELETED) (RETURN NIL)) ;; Otherwise, it's an internal local variable, ;; or else a special variable already bound by entering the function. ;; Don't bind, just init. (COND ((MEMBER INITFORM '(NIL (QUOTE NIL)) :TEST #'EQUAL) ;; if initting to NIL, then if no tags output so far (TAGOUT is NIL) ;; we can assume it is still NIL from function entry time. (WHEN (OR TAGOUT (EQ (VAR-TYPE HOME) 'FEF-SPECIAL) (VAR-OVERLAP-VAR HOME)) (OUTIV 'SET-NIL HOME))) ;; If explicitly says value does not matter, do nothing to initialize. ((OR (EQUAL INITFORM '(UNDEFINED-VALUE)) #+compiler:debug ; temporary while COMPILER2 package is being used. (EQUAL INITFORM '(COMPILER:UNDEFINED-VALUE))) NIL) ((EQUAL INITFORM ''0) (OUTIV 'SET-ZERO HOME)) (T (P2PUSH INITFORM) (OUTIV 'POP HOME))) ;; If there is a specified-flag variable, it was bound to T at entry. ;; Set it to NIL here (ie, if the arg was NOT specified). (WHEN (CDDR INTCODE) (OUTIV 'SET-NIL (CDDR INTCODE))) (RETURN NIL)))) (DEFUN OUTIV (INST VARAB &OPTIONAL ADR) ;; 10/18/86 DNG - Modified to handle initialization of higher-context lexical ;; variables; this is needed when EXTEND-LOCAL-VARIABLES has split the FEF. (DECLARE (UNSPECIAL ADR)) (WHEN (NULL ADR) (SETQ ADR (VAR-LAP-ADDRESS VARAB))) (IF (AND (CONSP ADR) (EQ (FIRST ADR) 'LEXICAL-REF) (ATOM (SETQ ADR (LEX-REF-ADDRESS ADR)))) (PROGN (UNLESS (EQ INST 'POP) (OUTI (LIST INST 0 'PDL-PUSH))) (P2PUSH-CONSTANT ADR) (NEEDPDL 1) (OUT-AUX 'STORE-IN-HIGHER-CONTEXT)) (OUTI (LIST INST 0 ADR)))) ;Bind a list of variables "in parallel": compute all values, then bind them all. ;Return the number of special bindings made (BIND-POP and BIND-NIL instructions). ;Note: an attempt to bind NIL is ignored at this level. ;Note: if several variables have init forms of (%pop), ;they are popped off the pdl LAST ONE FIRST! ;The "correct" thing would be to pop the first one first, ;but this would require another stack to keep them on to reverse them. (DEFUN P2-P-BIND (BOUNDVARS) ;; 8/23/85 - Set KEEP-CURRENT-FRAME flag when a special variable is bound. ;; 10/30/85 - Change instruction BINDNIL to BIND-NIL and BINDPOP to BIND-POP. ;; 12/07/85 - For release 3, FEF-ARG-AUX special variable is not bound on function entry. ;; 4/26/89 DNG - Original version of P2-P-BIND replaces P2PBIND. ;; 5/03/89 DNG - Add check for FEF-INI-SETQ. (IF (NULL BOUNDVARS) 0 (LET* ((PDLLVL PDLLVL) (HOME (FIRST BOUNDVARS)) (VARNAME (VAR-NAME HOME)) (INITFORM (AND (NOT (EQ (VAR-INIT-KIND HOME) 'FEF-INI-SETQ)) (VAR-INIT-FORM HOME))) NBINDS) (COND ((NULL VARNAME) (DEBUG-ASSERT NIL NIL "binding NIL") ; don't think this is needed anymore. -- DNG 5/3/89 ;; If trying to bind NIL, just discard the value to bind it to. (P2 INITFORM 'D-PDL) (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS))) (OUTF '(MOVE D-IGNORE PDL-POP))) ;; If this variable's binding is fully taken care of by function entry, ;; we have nothing to do here. ((AND (NOT (MEMBER (VAR-KIND HOME) '(FEF-ARG-INTERNAL-AUX FEF-ARG-KEY) :TEST #'EQ)) (NOT (EQ (VAR-INIT-KIND HOME) 'FEF-INI-COMP-C))) (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS)))) ;; Detect and handle internal special bound variables. ((EQ (VAR-TYPE HOME) 'FEF-SPECIAL) (COND ((OR (EQ INITFORM 'NIL) (EQUAL INITFORM '(QUOTE NIL))) (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS))) (OUTIV 'BIND-NIL HOME)) (T (P2PUSH INITFORM) (INCPDLLVL) (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS))) (OUTIV 'BIND-POP HOME))) (SETQ KEEP-CURRENT-FRAME T) (INCF NBINDS)) ((OR (EQUAL INITFORM '(UNDEFINED-VALUE)) #+compiler:debug ;temporary while COMPILER2 package is used (EQUAL INITFORM '(COMPILER:UNDEFINED-VALUE))) (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS)))) ((OR (EQ INITFORM 'NIL) (EQUAL INITFORM '(QUOTE NIL))) (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS))) (WHEN (OR TAGOUT (VAR-OVERLAP-VAR HOME)) (OUTIV 'SET-NIL HOME))) (T (P2PUSH INITFORM) (INCPDLLVL) (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS))) (OUTIV 'POP HOME))) NBINDS))) ;Compile code to test CONDITION and jump to tag if it is NIL ;(for SENSE = TRUE) or if it is non-NIL (for SENSE = FALSE). (DEFUN BOOL1 (CONDITION SENSE TAG) (P2BRANCH CONDITION 'D-INDS `(BRANCH NULL ,SENSE NIL ,TAG))) ;Like P2, but also supply a "branch destination". ;The branch destination (BDEST) is just a branch instruction which ;could simple-mindedly be compiled right after (P2 FORM DEST), ;but some forms can optimize the code produced by incorporating ;the branch destination into their code. Such forms can say that ;outputting the branch at the end is superfluous by setting BDEST to NIL. ;Forms which perform unconditional transfers need not worry about BDEST ;since it will be output and then discarded as unreachable. ;An unconditional branch destination can accompany any value of DEST. ;A conditional branch should only be used with DEST = D-INDS. ;This is taken to imply that the indicators are used by the branch, ;not that the indicators will be correctly set up after the optimized ;code is finished branching or not. If you wish to compile something ;and want the indicators correctly set up according to its value, ;you should use D-INDS with no BDEST, and do your branching yourself. ;Branches which pop the pdl may not be used as branch destinations. ;Most people who look at BDEST don't check for them, ;and the optimizations that BDEST is used for wouldn't work for them anyway. ;A funny kind of branch that can be used as a destination is ;(BRANCH ALWAYS NO-OP NIL tag). It is a sort of unconditional branch, ;used when the tag to be branched to is known to be right after ;this expression, so that one might think that no branch is needed at all. ;When OUTB is called on such a branch, it does nothing. ;But some functions (such as AND and OR) can optimize these no-op branches ;like any other unconditional branches. ;An even funnier kind of branch destination is the return branch: ;(BRANCH ALWAYS RETURN NIL tag). This is given as the branch destination ;to the last statement in a PROG, so that if the statement is a RETURN ;then the implicit (RETURN NIL) at the end of the PROG can be omitted ;and the RETURN at the end can just drop through to the PROG's rettag. ;Return branch destinations may not be passed along to subexpressions ;by AND, OR and COND. (DEFUN P2BRANCH (FORM DEST BDEST) (AND (MEMBER DEST '(D-PDL D-NEXT) :TEST #'EQ) (NEEDPDL 1)) (COND ((AND BDEST (NEQ (CADR BDEST) 'ALWAYS) (NEQ DEST 'D-INDS)) (BARF `(,DEST . ,BDEST) "BDEST is conditional and DEST is not D-INDS" 'BARF)) ;; We can optimize things like (AND 'T (GO FOO)) and (AND 'NIL (GO FOO)) ;; into an unconditional jump or into nothing at all. ((AND (EQ (CADR BDEST) 'NULL) (NULL (CADDDR BDEST)) (NOT (ATOM FORM)) (EQ (CAR FORM) 'QUOTE)) (AND (EQ (NULL (CADR FORM)) (EQ (CADDR BDEST) 'TRUE)) (OUTB `(BRANCH ALWAYS NIL ,@(COPY-LIST (CDDDR BDEST))))) (SETQ BDEST NIL)) ((ADRREFP FORM) (OR (EQ DEST 'D-IGNORE) (OUTI `(MOVE ,DEST ,(P2-SOURCE FORM DEST))))) ((EQ (CAR FORM) 'LEXICAL-REF) (P2 FORM DEST)) ((MEMBER (CAR FORM) '(%POP) :TEST #'EQ) (P2 FORM DEST)) (T (LET (M-V-TARGET) (P2F FORM DEST)))) (AND BDEST (OUTB (COPY-LIST BDEST)))) ;NOT compiles into a misc insn normally, ;but with a branch destination, it optimizes away by inverting the condition. (DEFPROP NOT P2NOT P2) (DEFUN P2NOT (ARGL DEST) ;; 8/17/85 - For release 3, special handling of D-RETURN; allow branch ;; conditions other than ATOM and NULL. ;; 9/19/85 - Use AUX RETURN-NOT-PDL-POP and PUSH-NOT instructions. ;; 9/26/85 - Use NOT-INDICATORS instruction. ;; 8/28/86 CLM - the call to P2ARGC no longer requires a DESC arg; just pass nil (COND ((/= (LENGTH ARGL) 1) ;; Wrong number of arguments; generate call so user gets error when executed. (P2ARGC NIL ARGL nil DEST P2FN)) ((AND BDEST (GET (CADR BDEST) 'DEF-BRANCH-OP)) (LET ((SENSE (OTHER (CADDR BDEST)))) (P2BRANCH (CAR ARGL) DEST `(BRANCH ,(CADR BDEST) ,SENSE ,@(CDDDR BDEST)))) (SETQ BDEST NIL)) #| ((AND (EQ DEST 'D-RETURN) (ADRREFP (FIRST ARGL))) (P2PUSH (FIRST ARGL)) (OUTI '(AUX RETURN-NOT-PDL-POP)) (SETQ DROPTHRU NIL) (comment ; use this if RETURN-NOT-PDL-POP is not supported. (P2MISC P2FN ARGL 'D-PDL 1) (MOVE-RESULT-FROM-PDL DEST)) ) |# #| ((INSTRUCTION-EXISTS-P 'PUSH-NOT) (LET ((ADR (P2-SOURCE (FIRST ARGL) 'D-PDL))) (IF (EQ ADR 'PDL-POP) (IF (EQ DEST 'D-RETURN) (PROGN (OUTI '(AUX RETURN-NOT-PDL-POP)) (SETQ DROPTHRU NIL)) (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'NOT)))) (IF (EQ DEST 'D-PDL) (OUTI `(PUSH-NOT 0 ,ADR)) (IF (EQ DEST 'D-RETURN) (PROGN (OUTI `(PUSH-NOT 0 ,ADR)) (MOVE-RESULT-FROM-PDL DEST)) (P2MISC P2FN ARGL DEST 1)))))) |# ((MISC-LAP-CODE 'NOT-INDICATORS) (P2 (FIRST ARGL) 'D-INDS) (IF (EQ DEST 'D-RETURN) (OUT-AUX 'RETURN-NOT-INDS) (OUTM `(MISC ,DEST ,(MISC-LAP-CODE 'NOT-INDICATORS))))) (T (P2MISC P2FN ARGL DEST 1)))) (DEFUN OTHER (SENSE) (COND ((EQ SENSE 'TRUE) 'FALSE) ((EQ SENSE 'FALSE) 'TRUE) (T (BARF SENSE 'OTHER 'BARF)))) (DEFPROP AND P2ANDOR P2) (DEFPROP OR P2ANDOR P2) (DEFUN P2ANDOR (ARGL DEST) ;; 4/10/85 DNG - Don't delete constant last argument unless the value is not used. [bug 1561] ;; 8/04/86 CLM - Handle cases where multiple values are expected but only a single value is ;; returned - when M-V-TARGET is RETURN or THROW. (PROG (TAG UNCONDITIONAL IDEST SENSE TAG1) (SETQ SENSE (IF (MEMBER P2FN '(AND :AND) :TEST #'EQ) 'TRUE 'FALSE)) (WHEN (MEMBER DEST '(D-INDS D-IGNORE) :TEST #'EQ) (DO () ((NOT (EQUAL (CAR (LAST ARGL)) (IF (EQ SENSE 'TRUE) ''T '(QUOTE NIL))))) (SETQ ARGL (BUTLAST ARGL)))) (SETQ IDEST 'D-PDL) ;; RETURN branches can't be passed in to the last thing in an AND. (AND (EQ (CADR BDEST) 'ALWAYS) (EQ (CADDR BDEST) 'RETURN) (SETQ BDEST NIL)) ;; Any non-null constant as arg in an AND is ignorable unless it is last. ;; NIL as arg in an OR is always ignorable. (SETQ ARGL (COND ((EQ SENSE 'FALSE) (DELETE '(QUOTE NIL) (THE LIST ARGL) :TEST #'EQUAL)) ((NULL ARGL) ARGL) (T (NREVERSE (CONS (CAR (LAST ARGL)) (DELETE NIL (THE LIST (CDR (NREVERSE ARGL))) :TEST #'(LAMBDA (IGNORE X) (AND (NOT (ATOM X)) (EQ (CAR X) 'QUOTE) (CADR X)))) ))) ) ) (OR ARGL (RETURN (PROG1 (P2BRANCH `',(EQ SENSE 'TRUE) DEST BDEST) (SETQ BDEST nil)))) ;; If we are going to jump somewhere unconditionally after the AND, ;; things which are NIL might as well jump conditionally straight there. ;; But this only works if the value of the AND will be in the right place then. (COND ((AND (EQ (CADR BDEST) 'ALWAYS) (NULL M-V-TARGET) (MEMBER DEST '(D-PDL D-INDS D-IGNORE) :TEST #'EQUAL)) (SETQ UNCONDITIONAL T) (SETQ TAG (CAR (CDDDDR BDEST)))) (T (SETQ TAG (GENSYM)))) (COND ((AND (NULL M-V-TARGET) (EQ DEST 'D-IGNORE)) ;; Compilation strategy for AND for effect: ;; compute each arg, using it only to jump to end if it's NIL. ;; The last one we just ignore, but we feed it our BDEST for ;; branch tensioning. However, (AND form (GO tag)) can be optimized ;; by making it a conditional jump to tag rather than a jump around a jump. (DO ((ARGL ARGL (CDR ARGL))) ((NULL (CDR ARGL)) (P2BRANCH (CAR ARGL) DEST BDEST)) (AND (SIMPLEGOP (CADR ARGL)) (RETURN (BOOL1 (CAR ARGL) (OTHER SENSE) (GTAG (CADADR ARGL))))) ;; If the next arg of this AND is NIL, this arg is effectively last. ;; However, if AND has a branch destination, it must compute ;; whether to branch based on the NIL, not on this arg. (AND (NOT (ATOM (CADR ARGL))) (EQ (CAADR ARGL) 'QUOTE) (EQ (NULL (CADADR ARGL)) (EQ SENSE 'TRUE)) (RETURN (P2BRANCH (CAR ARGL) DEST BDEST))) (BOOL1 (CAR ARGL) SENSE TAG))) ((AND (NULL M-V-TARGET) (EQ (CADR BDEST) 'NULL)) ;; Compilation strategy for AND followed by jump if NIL: ;; jump compute each value and jump THERE rather than to end if NIL. ;; Compilation strategy for AND followed by jump if not NIL: ;; put that jump if not NIL after the last thing in the AND ;; and go to after that if anything else fails to be non-NIL. (IF (EQ SENSE (CADDR BDEST)) (DO ((ARGL ARGL (CDR ARGL))) ((NULL ARGL)) (P2BRANCH (CAR ARGL) DEST BDEST)) (DO ((ARGL ARGL (CDR ARGL))) ((NULL (CDR ARGL)) (P2BRANCH (CAR ARGL) DEST BDEST)) ;; If the next arg of this AND is NIL, this arg is effectively last. ;; Also, BDEST can be flushed since it says branch if ;; not NIL and we now know the value of the AND is always NIL. (AND (NOT (ATOM (CADR ARGL))) (EQ (CAADR ARGL) 'QUOTE) (EQ (NULL (CADADR ARGL)) (EQ SENSE 'TRUE)) (RETURN (P2 (CAR ARGL) DEST))) (BOOL1 (CAR ARGL) SENSE TAG))) (SETQ BDEST NIL)) (T ;; Compilation strategy for AND for value ;; (correct indicators required counts as for value): ;; compile each arg, jumping to end if NIL. ;; Compile them to indicators, or to pdl and pop if NIL. ;; If compiling to indicators (no pushing), we can optimize ;; (AND form (GO tag)) just as when we are ignoring the value. (AND (EQ DEST 'D-INDS) (SETQ IDEST 'D-INDS)) ;; AND for multiple values is like AND for value on the stack, ;; except that we can pass the M-V-TARGET along to the last form. ;; Also, after the "end" where the failure branches branch to ;; we put code to push N-1 extra NILs, or whatever. ;; The code for the last form jumps around that, to the tag TAG1. (AND M-V-TARGET (SETQ IDEST 'D-PDL)) (DO ((ARGL ARGL (CDR ARGL)) (BRANCH `(BRANCH NULL ,SENSE ,(NEQ DEST 'D-INDS) ,TAG))) ((NULL (CDR ARGL)) ;; Compile the last form. If we want multiple values ;; and it handles them, then say the AND is handling them. (COND (M-V-TARGET (WHEN (NULL (P2MV (CAR ARGL) IDEST M-V-TARGET)) (SETQ TAG1 (GENSYM)))) (UNCONDITIONAL (P2BRANCH (CAR ARGL) DEST BDEST) (SETQ BDEST NIL)) (T (P2 (CAR ARGL) (IF (AND (EQ DEST 'D-RETURN) (NOT GENERATING-MICRO-COMPILER-INPUT-P)) DEST ;OK TO DISTRIBUTE DOWN A D-RETURN, SINCE ; IT IS AN IMPLICT TRANSFER IDEST))))) ;COMPILE TO IDEST, SINCE GOING TO ;FALL INTO COMMON POINT WHICH EXPECTS RESULT THERE (P2 (CAR ARGL) IDEST) (AND (EQ IDEST 'D-INDS) (SIMPLEGOP (CADR ARGL)) (RETURN (OUTB `(BRANCH NULL ,(OTHER SENSE) NIL ,(GTAG (CADADR ARGL)))))) (OUTB (COPY-LIST BRANCH))))) (COND (TAG1 ;; If we want multiple values, and the last form provides them, ;; say that the AND provides them, ;; and arrange to produce some in every other path. (OUTB `(BRANCH ALWAYS NIL NIL ,TAG1)) ;Last form jumps around. (OUTTAG TAG) ;Other paths come here. (COND ((NUMBERP M-V-TARGET) ;Turn single value into N values, (PUSH-NILS (1- M-V-TARGET))) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) ;or into a list of values. (OUTF '(MISC D-PDL NCONS))) (M-V-TARGET ;other cases where multiple values (P2PUSH-CONSTANT 1)) ;were expected but a single value returned ) (SETQ M-V-TARGET NIL) (OUTTAG TAG1)) ;Last form jumps here. ((NOT UNCONDITIONAL) (OUTTAG TAG) (OR (EQ DEST 'D-IGNORE) (EQ DEST 'D-INDS) (MOVE-RESULT-FROM-PDL DEST)))))) (DEFUN SIMPLEGOP (FORM) ;; Return T if given a (GO tag) which could be done with just a branch ;; (doesn't require popping anything off the pdl). ;; ;; 1/22/86 DNG - Fix to check for special bindings also. ;; 10/18/86 DNG - Use GOTAGS-SEARCH instead of ASSOC. ;; 11/17/86 CLM - Fix to check for lexical-closures. May have to do an ;; unshare, so don't return T. ;; 12/03/86 CLM - Fix to check for lexical closures. Faulty end-test was causing ;; an infinite loop. ;; 2/04/87 DNG - When LEXICAL-CLOSURE-COUNT is 0, don't bother looking for variables needing to be unshared. (AND (NOT (ATOM FORM)) (EQ (FIRST FORM) 'GO) (LET ((GOTAG (GOTAGS-SEARCH (SECOND FORM) T)) PD) (AND GOTAG (= PDLLVL (GOTAG-PDL-LEVEL GOTAG)) (SETQ PD (GOTAG-PROGDESC GOTAG)) (DOLIST (PROGDESC PROGDESCS T) (IF (EQ PROGDESC PD) (RETURN T) (UNLESS (AND (MEMBER (PROGDESC-NBINDS PROGDESC) '(0 NIL) :TEST #'EQ) (OR (ZEROP LEXICAL-CLOSURE-COUNT) (DO ((VS VARS (CDR VS)) (OVARS (PROGDESC-VARS PROGDESC))) ((OR (EQ VS OVARS) (NULL VS)) T) (LET ((V (CAR VS))) (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V) :TEST #'EQ) (RETURN NIL)))) ;DO ) );and (RETURN NIL)) )))))) (DEFPROP COND P2COND P2) (DEFUN P2COND (ARGL DEST) ;; 01/09/86 CLM - Modified for Release 3 so that if the selected clause is ;; the last (or only) clause and a singleton clause, then only ;; a single value will be returned - when compiling for Common ;; Lisp. ;; 02/14/86 DNG - Fix for returning NIL default when last clause does a GO. [SPR 1074] ;; 02/14/86 CLM - Handle cases where multiple values are expected but only a ;; single value is produced. ;; 9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET. ;; 9/22/86 DNG - Optimize COND to use SELECT instruction. ;; 7/13/87 DNG - Don't use P2SELECT unless (NO-SIDE-EFFECTS-P X). [SPR 5711] (IF (AND (> (LENGTH ARGL) 2) (NULL M-V-TARGET) (CONSP (CAR-SAFE (FIRST ARGL))) (LET ((X (SECOND (FIRST (FIRST ARGL)))) (N 0)) (AND (DOLIST (CLAUSE ARGL T) (LET ((TEST (CAR-SAFE CLAUSE))) (WHEN (ATOM TEST) (RETURN NIL)) (UNLESS (OR (AND (EQ (FIRST TEST) 'QUOTE) (SECOND TEST)) (AND (MEMBER (FIRST TEST) '(EQ MEMQ) :TEST #'EQ) (QUOTEP (THIRD TEST)) (EQUAL-FORMS (SECOND TEST) X) (OR (REST CLAUSE) (EQ (FIRST TEST) 'EQ) (MEMBER DEST '(D-IGNORE D-INDS))) (NULL (NTHCDR 3 TEST)))) (RETURN NIL)) (WHEN (> (INCF N) 3) (RETURN T)) )) (NO-SIDE-EFFECTS-P X)))) ;; then can optimize to use SELECT or DISPATCH instruction (P2SELECT ARGL DEST) ;; else normal COND processing (PROG (CLAUSE TAG TAG1 TAG2 VALF CLAUSE-LENGTH TM IDEST PRED NOFALLTHRU LAST-CLAUSE-FLAG IDEST-USED) (SETQ TAG2 (GENSYM)) ;TAG TO GO TO WITH VALUE OF COND IN DEST (SETQ TAG (GENSYM)) ;TAG TO GO TO WITH VALUE OF COND IN IDEST ;; Choose an intermediate destination, depending on ultimate destination. ;; The intermediate destination can match the ultimate one ;; if they are D-IGNORE, D-INDS or D-PDL. ;; Each COND clause can compile its value to IDEST and go to TAG ;; or compile its value to DEST and go to TAG2. ;; Use of TAG and IDEST assumes that multiple values were NOT generated ;; whereas TAG2 and DEST assumes that they were if they are supposed to be. ;; For microcompiler input, we always use TAG and IDEST unless IDEST=DEST. ;; Otherwise, we usually use DEST except for clauses that are just predicates. ;; IDEST-USED is T if a clause has compiled its result to IDEST. ;; The code to move the value is only generated if IDEST/TAG has been used. (AND M-V-TARGET (SETQ DEST 'D-PDL)) (SETQ IDEST 'D-IGNORE) (UNLESS (EQ DEST 'D-IGNORE) (SETQ VALF T) (SETQ IDEST 'D-PDL)) (WHEN (EQ DEST 'D-INDS) (SETQ IDEST 'D-INDS)) ;; Compile next clause. L1 (WHEN (NULL (CDR ARGL)) (SETQ LAST-CLAUSE-FLAG T)) (SETQ CLAUSE (CAR ARGL)) ;;the following clause changed 01/09/86 by CLM ;;if compiling for common-lisp, multiple values should ;;not be returned if the last clause is a singleton clause. (AND (NOT COMPILING-COMMON-LISP) LAST-CLAUSE-FLAG (NULL (CDR CLAUSE)) (SETQ CLAUSE (CONS ''T CLAUSE))) (SETQ TAG1 (GENSYM)) (SETQ PRED (CAR CLAUSE)) (WHEN (AND (NOT (ATOM PRED)) (EQ (CAR PRED) 'QUOTE)) (COND ((NULL (CADR PRED)) ;IS THE NULL CONDITION? (AND (NOT LAST-CLAUSE-FLAG) (GO L5))) ;YEP. CAN HAPPEN AS RESULT OF DO EXPANSION. ((CDR ARGL) ;condition always true? (SETQ LAST-CLAUSE-FLAG T) ;If so, discard any remaining clauses (SETQ NOFALLTHRU T) ;after a warning about them. ;These can come from expanding DEFSUBSTs that contain CONDs, with constant arguments. ; (WARN 'UNREACHABLE-CODE ':IMPLAUSIBLE ; "Some COND clauses are unreachable; ; the first starts with ~S." ; (CAADR ARGL)) (SETQ ARGL (LIST CLAUSE))) (T (SETQ NOFALLTHRU T)))) (SETQ CLAUSE-LENGTH (LENGTH CLAUSE)) ;; Handle certain special cases of clauses. (COND ((AND VALF (= 1 CLAUSE-LENGTH)) ;; Clause containing only one element, compiled for value. ;; value of condition is also value of clause. (P2 PRED IDEST) (SETQ IDEST-USED T) ;;if clause is the last of the COND, don't generate ;;an unnecessary branch (UNLESS LAST-CLAUSE-FLAG (OUTB (LIST 'BRANCH 'NULL 'FALSE (EQ IDEST 'D-PDL) ;IF SOMETHING PUSHED, POP IF TAG))) ; THE BRANCH IS NOT TAKEN (GO L5)) ;; Clause of one element, if value is not wanted. ((= 1 CLAUSE-LENGTH) (BOOL1 PRED 'FALSE TAG) (GO L5)) ;; Clause is just condition followed by a GO. ((AND (= 2 CLAUSE-LENGTH) (SIMPLEGOP (CADR CLAUSE)) (NOT (AND VALF LAST-CLAUSE-FLAG))) (BOOL1 PRED 'FALSE (GTAG (CADADR CLAUSE))) (GO L5)) ;; Clause after this one is (T (GO ...)). ;; Can get special handling only if the GO ;; requires no pdl adjustment. ((AND (NOT NOFALLTHRU) ;ISOLATE CASE OF (NOT LAST-CLAUSE-FLAG) ;((P1 A1) (T (GO X))) (NOT (ATOM (CAR (SETQ TM (CADR ARGL))))) (EQ (CAAR TM) 'QUOTE) (CADAR TM) (= 2 (LENGTH TM)) (SIMPLEGOP (CADR TM))) ;; In effect, we turn this into (COND ((NOT P1) (GO X)) (T A1)) (BOOL1 PRED 'TRUE (GTAG (CADADR TM))) ;GO X DIRECTLY IF P1 FALSE (SETQ ARGL (CONS (CONS ''T (CDR CLAUSE)) (CDDR ARGL))) (GO L1)) ((NOT NOFALLTHRU) ;Normal COND clause. (BOOL1 PRED 'TRUE TAG1))) ;Jump around clause if predicate fails. ;; If the COND will have to return NIL if this clause's ;; condition is false, then generate a clause to return the nil. (WHEN (AND VALF LAST-CLAUSE-FLAG (NOT NOFALLTHRU)) (SETQ ARGL (LIST CLAUSE '('T (QUOTE NIL)))) (SETQ LAST-CLAUSE-FLAG NIL)) ;; Compile the actions of the cond clause, except for the last. (DO ((ACTIONS (CDR CLAUSE) (CDR ACTIONS))) ((NULL (CDR ACTIONS)) (SETQ CLAUSE ACTIONS)) (P2 (CAR ACTIONS) 'D-IGNORE)) ;; Compile last action of cond clause (the value). (LET ((TO-IDEST-P ;; Send value of last clause to IDEST rather than DEST ;; if that means we can avoid a branch to TAG2 ;; that would otherwise be necessary. ;; Send values of all clauses to IDEST for microcompiler input. (OR (AND LAST-CLAUSE-FLAG IDEST-USED (NEQ DEST IDEST) ;; Don't do this optimization if mult values wanted ;; because only compilation to DEST can accept them. (NULL M-V-TARGET) ;; If D-RETURN, don't optimize, so it can propagate ;; multiple values if there are any. (NEQ DEST 'D-RETURN)) (AND GENERATING-MICRO-COMPILER-INPUT-P (NOT (EQ DEST IDEST)))))) (COND (TO-IDEST-P (P2 (CAR CLAUSE) IDEST)) ((EQUAL (CAR CLAUSE) '(QUOTE NIL)) ;; Avoid "Doesn't really produce multiple values" ;; for internally generated 'NIL. (P2 '(QUOTE NIL) DEST) (AND M-V-TARGET (SETQ TO-IDEST-P T))) ((P2MV (CAR CLAUSE) DEST M-V-TARGET) ;; If value fails to generate mult vals, ;; we must make TAG generate them and go there. (SETQ TO-IDEST-P T))) (COND ((NULL TO-IDEST-P) (WHEN (OR (NULL LAST-CLAUSE-FLAG) ;; If last clause, and TAG isn't the same as TAG2, ;; we must still branch to TAG2. (AND IDEST-USED (OR M-V-TARGET (NEQ DEST IDEST)))) (OUTB (LIST 'BRANCH 'ALWAYS NIL NIL TAG2)))) (T (SETQ IDEST-USED T) (WHEN (NULL LAST-CLAUSE-FLAG) (OUTB (LIST 'BRANCH 'ALWAYS NIL NIL TAG)))))) ;; Here at end of cond-clause. L5 (OUTTAG TAG1) ;Output tag for jumps from failing predicate. (WHEN (SETQ ARGL (CDR ARGL)) (GO L1)) ;; There are no more cond clauses! (OUTTAG TAG) ;;multiple values were expected but not produced (AND IDEST-USED (COND ((NUMBERP M-V-TARGET) (PUSH-NILS (1- M-V-TARGET))) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (OUTM '(MISC D-PDL NCONS))) ;; 2/14/86 if mvtarget was return or throw ;;set up for a return/throw-n of 1 ((OR (EQ M-V-TARGET 'THROW) (EQ M-V-TARGET 'RETURN) (EQ M-V-TARGET 'RETURN-CATCH)) (P2PUSH-CONSTANT 1)) ((NEQ DEST IDEST) (MOVE-RESULT-FROM-PDL DEST)))) ;; We have generated multiple values if necessary. (SETQ M-V-TARGET NIL) (OUTTAG TAG2) (RETURN NIL)))) (DEFUN P2SELECT (ARGL DEST) ;; Optimize a COND form to use a SELECT or DISPATCH instruction. ;; 9/05/86 DNG - Original. ;; 10/11/86 DNG - Can't use DISPATCH unless selector is known to be an integer. ;; 12/23/86 DNG - Bind PDLLVL so that P2PROGN doesn't increment it for each clause. ;; 12/31/86 DNG - Bind BDEST to NIL to prevent inappropriate optimizations. [SPR 2911] ;; 6/29/87 DNG - Don't generate code for duplicated values in order to avoid ;; compiling internal functions that are only referenced in the unused code. ;; [part of SPR 5719] (LET* ((VALUE-LIST NIL) (TAG-LIST NIL) (EXIT-TAG (MAKE-LAP-TAG)) (OTHERWISE-TAG NIL) LAP-INDEX ; array index where SELECT will be placed. (SELECTOR (SECOND (FIRST (FIRST ARGL)))) ) (P2PUSH SELECTOR) (OUTF NIL) ; reserve space for possible ADD-IMMED before DISPATCH (SETF LAP-INDEX (FILL-POINTER QCMP-OUTPUT)) (OUTF 'SELECT) ; reserve space for inserting SELECT or DISPATCH instruction (SETQ DROPTHRU NIL) (DO ((CLAUSES ARGL (CDR CLAUSES))) ; for each COND clause ((NULL CLAUSES)) (LET* ((CLAUSE (FIRST CLAUSES)) (TAG (MAKE-LAP-TAG)) (TEST (FIRST CLAUSE)) (TAG-USED NIL)) (COND ((AND (EQ (CAR-SAFE TEST) 'EQ) (QUOTEP (THIRD TEST)) (EQUAL-FORMS (SECOND TEST) SELECTOR)) (LET (( VALUE (SECOND (THIRD TEST)) )) (UNLESS (MEMBER VALUE VALUE-LIST :TEST #'EQ) (PUSH VALUE VALUE-LIST) (PUSH TAG TAG-LIST) (SETQ TAG-USED T)))) ((EQ (CAR-SAFE TEST) 'QUOTE) ; otherwise case (DEBUG-ASSERT (SECOND TEST)) (SETF OTHERWISE-TAG TAG) (SETQ TAG-USED T)) ((AND (EQ (CAR-SAFE TEST) 'MEMQ) (QUOTEP (THIRD TEST)) (EQUAL-FORMS (SECOND TEST) SELECTOR)) (DOLIST (VALUE (SECOND (THIRD TEST))) (UNLESS (MEMBER VALUE VALUE-LIST :TEST #'EQ) (PUSH VALUE VALUE-LIST) (PUSH TAG TAG-LIST) (SETQ TAG-USED T)))) (T (SETF CLAUSE `(T (COND . ,CLAUSES))) (SETF CLAUSES NIL) (SETF OTHERWISE-TAG TAG) (SETQ TAG-USED T)) ) (WHEN TAG-USED (OUTTAG-FORCED TAG) (LET ((PDLLVL PDLLVL) (BDEST NIL)) (IF (NULL (REST CLAUSE)) (P2 '(QUOTE T) DEST) (P2PROGN (REST CLAUSE) DEST))) (OUTB `(BRANCH ALWAYS NIL NIL ,EXIT-TAG))) )) ; end of loop on COND clauses (WHEN (NULL OTHERWISE-TAG) ; no explicit otherwise (SETF OTHERWISE-TAG (MAKE-LAP-TAG)) (OUTTAG-FORCED OTHERWISE-TAG) (P2 '(QUOTE NIL) DEST) (OUTB `(BRANCH ALWAYS NIL NIL ,EXIT-TAG))) (OUTTAG EXIT-TAG) (LET* ((MIN (FIRST VALUE-LIST)) (MAX MIN) (NVALUES (LENGTH VALUE-LIST))) (IF (AND (DOLIST (VALUE VALUE-LIST T) (UNLESS (INTEGERP VALUE) (RETURN NIL)) (IF (> VALUE MAX) (SETF MAX VALUE) (IF (< VALUE MIN) (SETF MIN VALUE)))) (<= (- MAX MIN) (* NVALUES 2)) (EXPR-TYPE-P SELECTOR 'INTEGER)) ;; All of the values are integers and reasonably contiguous, so ;; use a DISPATCH instruction instead of SELECT. (PROGN (IF (<= 0 MIN (OPT-SPEED OPTIMIZE-SWITCH)) (SETQ MIN 0) (SETF (AREF QCMP-OUTPUT (- LAP-INDEX 1)) `(- 0 (QUOTE-VECTOR ',MIN)))) (LET* ((TAG-TABLE (MAKE-ARRAY (+ (- MAX MIN) 1) :INITIAL-ELEMENT OTHERWISE-TAG))) (DOLIST (VALUE VALUE-LIST) (SETF (AREF TAG-TABLE (- VALUE MIN)) (FIRST TAG-LIST)) (SETF TAG-LIST (REST TAG-LIST))) (SETF (AREF QCMP-OUTPUT LAP-INDEX) `(DISPATCH ,OTHERWISE-TAG ,TAG-TABLE)))) ;; Else, finish setting up the SELECT instruction. (LET ((TAG-TABLE (MAKE-ARRAY NVALUES)) (VALUE-TABLE (NREVERSE VALUE-LIST))) (DO ((I (- NVALUES 1) (- I 1))) ((< I 0)) (SETF (AREF TAG-TABLE I) (FIRST TAG-LIST)) (SETF TAG-LIST (REST TAG-LIST))) (SETF (AREF QCMP-OUTPUT LAP-INDEX) `(SELECT ,OTHERWISE-TAG ,TAG-TABLE ,VALUE-TABLE))) )))) (DEFUN (:PROPERTY %DISPATCH P2) (ARGL DEST) ;; (%DISPATCH selector max default . body) ;; 1 2 3 4 ... ;; 12/07/85 DNG - Original version. ;; 9/05/86 DNG - Don't need PEEP-KEEP property anymore. (P2 (FIRST ARGL) 'D-PDL) ; selector expression (LET (TABLE ; dispatch table (TAG NIL) END-TAG) (LET ((OTHERWISE-TAG (MAKE-LAP-TAG))) (SETQ TABLE (MAKE-ARRAY (+ (SECOND ARGL) 1) :INITIAL-ELEMENT OTHERWISE-TAG)) (OUTI `(DISPATCH ,OTHERWISE-TAG ,TABLE)) ; note table is filled in below. (OUTF '(NO-DROP-THROUGH)) (IF (AND (EQ DEST 'D-IGNORE) (NO-SIDE-EFFECTS-P (THIRD ARGL))) (SETQ END-TAG OTHERWISE-TAG) (PROGN (OUTF OTHERWISE-TAG) (P2 (THIRD ARGL) DEST) ; default action (OUTB `(BRANCH ALWAYS NIL NIL ,(SETQ END-TAG (MAKE-LAP-TAG))))))) (DOLIST (FORM (NTHCDR 3 ARGL)) (IF (FIXNUMP FORM) ; value tag (PROGN (WHEN (NULL TAG) (SETQ TAG (MAKE-LAP-TAG)) (UNLESS DROPTHRU (OUTF '(NO-DROP-THROUGH)) (SETQ DROPTHRU T)) (OUTF TAG)) (SETF (AREF TABLE FORM) TAG)) (PROGN (SETQ TAG NIL) (P2 FORM 'D-IGNORE)))) (P2 '(QUOTE NIL) DEST) (OUTF END-TAG))) (DEFUN GOTAGS-SEARCH (TAG &OPTIONAL NO-ERROR TAGS-LIST) ;; 8/28/85 - In order to avoid giving invalid code to the peephole optimizer ;; when the named tag is undefined, try to return some valid tag ;; instead of NIL. [SPR 501] ;; 10/18/86 - Now that GO forms contain the tag structure instead of the symbol, just return the argument. (IGNORE NO-ERROR TAGS-LIST) TAG #| old way (IF (CONSP TAG) TAG (OR (ASSOC TAG (OR TAGS-LIST GOTAGS) :TEST #'EQUAL) (PROGN (WHEN NO-ERROR (RETURN-FROM GOTAGS-SEARCH NIL)) (WARN 'BAD-GO-TAG :IMPOSSIBLE "There is a GO to tag ~S but no such tag exists." TAG) (PROGDESC-RETTAG (FIRST PROGDESCS))) (FIRST GOTAGS))) |# ) (DEFUN GTAG (X) (GOTAG-LAP-TAG (GOTAGS-SEARCH X))) ;Output an unconditional jump to a specified tag, popping the pdl if necessary. ;Barf if the tag is not known on GOTAGS. (DEFUN OUTB1 (TAG) (OUTBRET TAG nil 0)) ;Output an unconditional transfer to the specified prog tag, ;popping the pdl the appropriate number of times to adjust the ;pdl from its current level to the level required at that tag. ;For handling GO, PROGDESC should be NIL and NVALUES should be 0. ;When jumping to the return tag of a prog, PROGDESC should be ;the desc for the prog we are returning from, and NVALUES should be ;the number of things on the top of the stack which are being left ;there as values to return from the prog. (DEFUN OUTBRET (TAG PROGDESC NVALUES) ;; 11/17/86 CLM - Fix to do an unshare if in a lexical-closure. (LET* ((EXITPROGDESC PROGDESC) (TM (GOTAGS-SEARCH TAG))) (UNLESS (NULL TM) ;; If this is GO, set EXITPROGDESC to the progdesc of its containing PROG (UNLESS PROGDESC (SETQ EXITPROGDESC (GOTAG-PROGDESC TM))) (POP-FRAMES EXITPROGDESC NVALUES) ;; For a prog rettag, the pdl level should include ;; the number of values desired on the stack. (POPPDL NVALUES (- PDLLVL (GOTAG-PDL-LEVEL TM))) ;;do an unshare if needed (WHEN (> LEXICAL-CLOSURE-COUNT 0) (P2 `(UNSHARE-STACK-CLOSURE-VARS ,VARS ,(PROGDESC-VARS EXITPROGDESC)) 'D-IGNORE)) (OUTB `(BRANCH ALWAYS NIL NIL ,(GOTAG-LAP-TAG TM))) NIL)) ) (DEFUN POP-FRAMES (EXITPROGDESC NVALUES) ;; If we are exiting any PROGs, unwind stacks to their levels. ;; Does not include the prog whose desc is EXITPROGDESC. ;; ;; 12/15/86 DNG - Update to handle special-pdl-index that has been saved in a ;; local variable. (LET ((N-UNBINDS 0) (LAST-VARIABLE-UNBIND-PDL-LEVEL NIL)) (DO ((L PROGDESCS (CDR L))) ((EQ (CAR L) EXITPROGDESC)) (LET ((NBINDS (PROGDESC-NBINDS (CAR L)))) (IF (CONSP NBINDS) ; dynamic binding (PROGN (SETQ LAST-VARIABLE-UNBIND-PDL-LEVEL (OR (SECOND NBINDS) ; special-pdl-index saved in local variable (PROGDESC-PDL-LEVEL (CAR L)) ; index on stack )) (SETQ N-UNBINDS (FIRST NBINDS)) ; bindings before the index ) (INCF N-UNBINDS NBINDS)))) (COND ((NULL LAST-VARIABLE-UNBIND-PDL-LEVEL)) ((FIXNUMP LAST-VARIABLE-UNBIND-PDL-LEVEL) ;; LAST-VARIABLE-UNBIND-PDL-LEVEL is the level at start of PROG body, ;; and does not include the values we want to return. ;; PDLLVL at all times includes those values ;; since they are already on the stack. (POPPDL NVALUES (- PDLLVL NVALUES LAST-VARIABLE-UNBIND-PDL-LEVEL)) (OUTPUT-UNBIND-TO-INDEX NVALUES) (SETQ PDLLVL (+ LAST-VARIABLE-UNBIND-PDL-LEVEL NVALUES -1))) ((DEBUG-ASSERT (CONSP LAST-VARIABLE-UNBIND-PDL-LEVEL)) ;; the special-pdl-index was saved in a local variable (P2PUSH LAST-VARIABLE-UNBIND-PDL-LEVEL) (OUTPUT-UNBIND-TO-INDEX 0))) (UNBIND 'D-IGNORE N-UNBINDS))) ;Pop NPOPS words off the pdl, from underneath the top NVALUES words. ;We do not change PDLLVL. (DEFUN POPPDL (NVALUES NPOPS) ;; 8/10/85 DNG - Modified for release 3. ;; 9/25/85 DNG - POP-M-FROM-UNDER-N is now an AUX op; ;; change instruction name from POPPDL to POP-PDL. ;; 12/05/85 CLM - Emit a %CLOSE-CATCH instead of POP-OPEN-CALL ;; to pop catch blocks. ;; 1/30/86 CLM - Modified for cases where there is a return from ;; within a CATCH or an UNWIND-PROTECT ;; 2/05/86 CLM - An addendum to the above modification. This handles ;; returns from within the cleanup-forms of an unwind-protect. ;; 2/12/86 CLM - Fix to prevent too many pops from taking place. ;; 5/29/86 CLM - Fix so that after a close-catch, NPOPS will be decremented ;; by the correct number of words. Use the constant CATCH-BLOCK-SIZE ;; for the current number. ;; 11/17/86 CLM - Changed to handle new UNWIND-PROTECT scheme. ;; 11/24/86 CLM - For unwind-protect undo forms, make sure that the block being exited is ;; the unwind-protect block and not a block generated within the undo forms ;; before doing special handling. ;; 4/05/89 DNG - Removed obsolete code for VM1. ;(print (list 'poppdl nvalues npops)) (COND #+compiler:debug ((MINUSP NPOPS) (BARF NPOPS "negative number of pops" 'BARF)) (T ;; Output enough POP-OPEN-CALL instructions to flush ;; any unwind protects inside the desired pdl level. ;; For Rel. 3 use %CLOSE-CATCH. (DO ((I 0 (1+ I)) (N 0) (L CALL-BLOCK-PDL-LEVELS (CDR L)) (CBPL CALL-BLOCK-PDL-LEVELS) (UNDO-PDL-LEVEL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS)))) ((OR (NULL L) ;;making a change here---------- ;;instead of <= use < so that if the levels ;;happen to be equal a close catch will be done (< (IF (CONSP (CAR L)) (CAAR L) (CAR L)) (- PDLLVL NPOPS NVALUES))) ;; N is the number of frames we must flush ;; to take us past all the unwind-protects. (DOTIMES (J N) (IF (AND (CONSP (CAR CBPL)) (EQ (CADAR CBPL) 'UNWIND-PROTECT)) (IF (AND (EQ (CAR (LAST (CAR CBPL))) 'UNDO) UNDO-PDL-LEVEL) (LET ((PDLLVL-DELTA (- PDLLVL (CAR UNDO-PDL-LEVEL)))) (IF (ZEROP PDLLVL-DELTA) (OUT-AUX 'POP-PDL 1) ;haven't added to stack but must pop restart-macro-pc (OUT-AUX 'POP-PDL PDLLVL-DELTA)) (OUT-AUX '%UNWIND-PROTECT-CLEANUP) (DECF PDLLVL (IF (ZEROP PDLLVL-DELTA) 1 PDLLVL-DELTA)) (POP UNDO-PDL-LEVEL) ;;IF EXITING THE UNDO FORMS MUST MAKE SURE ANYTHING LEFT ON THE STACK ;;BY THE PROTECTED FORMS IS ALSO POPPED (UNLESS (= (CAAR CBPL) PDLLVL) (OUT-AUX 'POP-PDL (- PDLLVL (CAAR CBPL))) (DECF PDLLVL (- PDLLVL (CAAR CBPL)))) ) (PROGN (OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT) (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE)) (SETQ NPOPS (- NPOPS CATCH-BLOCK-SIZE)) (OUTB `(BRANCH PUSHJ NIL NIL ,(CADDAR CBPL))) (OUT-AUX '%UNWIND-PROTECT-CONTINUE))) (PROGN (OUT-AUX '%CLOSE-CATCH) (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE)) (SETQ NPOPS (- NPOPS CATCH-BLOCK-SIZE))) ) ;;(SETQ NPOPS (- NPOPS CATCH-BLOCK-SIZE)) (SETQ CBPL (CDR CBPL)))) (SETQ N (1+ I))) (UNLESS (= NPOPS 0) (COND ((> NVALUES 1) (P2PUSH-CONSTANT NPOPS) (P2PUSH-CONSTANT NVALUES) (OUT-AUX 'POP-M-FROM-UNDER-N)) ((= NVALUES 1) (P2PUSH-CONSTANT NPOPS) (OUTI '(MISC D-PDL SHRINK-PDL-SAVE-TOP))) (T (DO ((N 15 (+ N 15))) ;; N is number of pops we would have done if we now do ;; another POPPDL 17. N-17 is number of pops so far. ((> N NPOPS) (UNLESS (= NPOPS (- N 15)) (OUT-AUX 'POP-PDL (- NPOPS (- N 15))))) (OUT-AUX 'POP-PDL 15)))))))) (DEFPROP LDB P2LDB P2) (DEFUN P2LDB (ARGL DEST) ;; 3/21/86 CLM - Original version - where possible use LDB-IMMED instead ;; the LDB misc-op. ;; 3/21/86 DNG - Don't use LDB-IMMED unless DEST is D-PDL. ;; 3/24/86 DNG - Put NO-D-RETURN around P2MISC call. ;; 8/28/86 CLM - no longer pass DESC arg to p2argc, just nil ;; 9/22/86 DNG - Don't generate LDB instruction when DEST is D-IGNORE. (LET ((NARGS 2)) (IF (= (LENGTH ARGL) NARGS) ;;ldb should have two args (IF (EQ DEST 'D-IGNORE) (ARGLOAD ARGL DEST) (IF (AND (QUOTEP (FIRST ARGL)) (INTEGERP (SECOND (FIRST ARGL))) (INSTRUCTION-EXISTS-P 'LDB-IMMED) (EQ DEST 'D-PDL)) (LET ((PP (BYTE-POSITION (SECOND (FIRST ARGL)))) (SS (BYTE-SIZE (SECOND (FIRST ARGL)))) (PPSS 0)) (IF (OR (> PP 31) (> SS 15)) ;;the byte specifier won't fit the 9 bit field of the ;;immed instr (P2MISC 'LDB ARGL DEST NARGS) (PROGN ;;byte will fit in 9 bit field ;;first must reshape the ppss arg to fit into 9 bits ;;5 bit position, 4 bit size (SETQ PPSS (DPB PP (BYTE 5 4) (DPB SS (BYTE 4 0) PPSS))) (P2PUSH (SECOND ARGL)) (OUTI `(LDB-IMMED ,PPSS))))) (NO-D-RETURN (P2MISC 'LDB ARGL DEST NARGS)))) (P2ARGC NIL ARGL nil DEST 'LDB)))) (DEFUN (:PROPERTY %LOAD-MEMORY-MAP P2) (ARGL DEST) ;; This misc-op needs special handling because it pushes two values on the stack. ;; 9/??/86 EPM - Original version hacked from P2FLOOR. ;; 9/25/86 DNG - Updated for rel3 compiler. (IF (NOT (= (LENGTH ARGL) 4)) ; wrong number of arguments (P2ARGC NIL ARGL NIL DEST '%LOAD-MEMORY-MAP) (PROGN (ARGLOAD ARGL 'D-PDL) (OUTM '(MISC D-PDL %LOAD-MEMORY-MAP)) (COND ((EQ DEST 'D-RETURN) (OUTI '(AUX RETURN-0 2)) (SETQ DROPTHRU NIL)) ((EQ M-V-TARGET 'MULTIPLE-VALUE-LIST) (OUTM '(MISC D-PDL NCONS)) (OUTM '(MISC D-PDL CONS))) ((EQ M-V-TARGET 'THROW) (P2PUSH-CONSTANT 2)) ((MEMBER M-V-TARGET '(RETURN RETURN-CATCH) :TEST #'EQ) (P2PUSH-CONSTANT 2)) ((AND (FIXNUMP M-V-TARGET) (>= M-V-TARGET 2)) (PUSH-NILS (- M-V-TARGET 2))) (T (WARN '%LOAD-MEMORY-MAP :IMPOSSIBLE "~A called without accepting 2 values" '%LOAD-MEMORY-MAP))) (SETQ M-V-TARGET NIL)))) (DEFUN (:PROPERTY SI:STORE-KEYARGS P2) (ARGL DEST) ;; 5/04/89 DNG - Original, added to use aux-op %STORE-KEY-WORD-ARGS. ;; Note that this optimization must be done in pass 2 because ;; EXTEND-LOCAL-VARIABLES could cause the STORE-KEYARGS to be moved to an ;; internal function after pass 1 has finished. (IF (LET ((TM (FIRST ARGL))) ; the plist of actual keys and values ;; Is it the rest arg of the current FEF? (AND (EQ (CAR-SAFE TM) 'LOCAL-REF) (EQ (VAR-KIND (SETQ TM (SECOND TM))) 'FEF-ARG-REST) (EQ (VAR-COMPILAND TM) *CURRENT-COMPILAND*) #| -- on second thought, don't need this check because this has been in the microcode since 3.2. ;; For release 6, don't use this if generating an object file that might be ;; loaded on an earlier release. (OR #.(> (TIME:GET-UNIVERSAL-TIME) (TIME:PARSE-UNIVERSAL-TIME "1/1/90")) QC-FILE-LOAD-FLAG FILE-IN-COLD-LOAD (ASSOC (PACKAGE-NAME *PACKAGE*) SYS::INITIAL-PACKAGES :TEST #'EQUAL) (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))) |# )) ;; Can use the microcoded version. ;; rest arg is implicit (P2F `(%STORE-KEY-WORD-ARGS . ,(CDR ARGL)) DEST) ;; Else use Lisp version. (P2ARGC NIL ARGL NIL DEST 'SI:STORE-KEYARGS))) ;;; New special forms for CLOS - added to this file 3/15/89 ;; generic function hash table support (DEFUN (:PROPERTY si:%generic-function-hash-table P2) (ignore dest) ;; 1/04/88 DNG - Warn if within a CATCH -- that won't work because ;; %DISPATCH-METHOD does a tail-recursive call. (when WITHIN-CATCH (warn 'si:%generic-function-hash-table ':PROBABLE-ERROR "Can't use CATCH in a generic function")) ;;have to do this consing because QADD destructively modifies the instruction ;;which will modify it in this fef also (let ((temp '(%generic-function-hash-table))) (setf (getf (compiland-plist *current-compiland*) 'generic-function) t) (OUTI `(MOVE ,dest (QUOTE-VECTOR ,temp))))) (DEF SYS:%APPLY-METHOD) (DEFPROP SYS:%APPLY-METHOD (METHOD ARG-LIST MAP-LIST &OPTIONAL CONTINUATION) ARGLIST) ;;;method calling ;;;form: (sys:%apply-method method arg-list map-list &optional continuation) (defun (:property sys:%apply-method p2) (argl dest) ;; 4/18/88 clm - new for clos method calling. ;; 5/02/88 clm - the aux-op apply-method has not been done yet; this is intended ;; as a future optimization. ;; 4/14/89 DNG - Optimize for NCONS as well as LIST. ;; 4/21/89 DNG - Include the aux-op optimization. (let ((arglist (second argl)) (lexpr-funcallp t)) (if (and (null m-v-target) (or (null (fourth argl)) (equal (fourth argl) '(quote nil)))) (progn (p2 arglist 'd-pdl) ;;argument list (p2 (third argl) 'd-pdl) ;;mapping-table list (p2 (first argl) 'd-pdl) ;;function object (outi `(aux apply-method ,dest))) (let ((args (cond ((member (car-safe arglist) '(list ncons)) ;;arglist of form ((list a b c ...))) (setf lexpr-funcallp nil) (cdr arglist)) ((or (eq (car-safe arglist) 'list*) (eq (car-safe arglist) 'cons)) (setf lexpr-funcallp t) (cdr arglist)) (t (list arglist))))) (p2argc (car argl) args lexpr-funcallp dest nil (third argl) (or (fourth argl) t))) ;;use t here to flag this is a new method call, but ;;no continuation ) )) (DEF %STANDARD-INSTANCE-REF) (DEFPROP %STANDARD-INSTANCE-REF (OBJECT MAPPING-TABLE "E CLASS-NAME SLOT-NAME) ARGLIST) ;; Eventually this should be done in P2-SOURCE instead. (DEFUN (:PROPERTY %STANDARD-INSTANCE-REF P2) (ARGL DEST) ;; 5/05/88 DNG - Original. ;; 5/09/88 DNG - Use new function INSTANCE-REF-HANDLER. (OUTI `(MOVE ,DEST ,(INSTANCE-REF-HANDLER ARGL)))) (DEFUN INSTANCE-REF-HANDLER (ARGL) ;; 5/09/88 DNG - Original. (DESTRUCTURING-BIND (OBJECT MAPPING-TABLE CLASS-NAME SLOT-NAME) ARGL (debug-assert (eq (car-safe OBJECT) 'local-ref)) (debug-assert (eq (car-safe MAPPING-TABLE) 'local-ref)) (LET* ((ADDRESS (VAR-LAP-ADDRESS (SECOND OBJECT))) (NUMBER (DPB (SECOND ADDRESS) SYS:%%CLOS-SELF-REF-INSTANCE-REF-INDEX (DPB (IF (EQ (FIRST ADDRESS) 'LOCBLOCK) 1 0) SYS:%%CLOS-SELF-REF-INSTANCE-REF-ADDRESSING-MODE (DPB (SECOND (VAR-LAP-ADDRESS (SECOND MAPPING-TABLE))) SYS:%%CLOS-SELF-REF-MAPPING-TABLE-LOCAL-INDEX '#,(%LOGDPB 1 SYS:%%CLOS-SELF-REF-RELOCATE-FLAG (%LOGDPB 1 SYS:%%SELF-REF-TYPE-FLAG 0))))))) `(QUOTE-VECTOR (TICLOS:CLOS-VAR-POINTER ,NUMBER ',CLASS-NAME ',SLOT-NAME))))) (DEFUN MAP-SPEC (ARG) ;; Given an argument reference, return the DTP-SELF-REF-POINTER number for ;; accessing the map for a subclass. The class name of ARG is returned as ;; the second value. ;; 5/06/88 DNG - Original. ;; 5/10/88 DNG - Use TICLOS:TYPE-NAME instead of ENSURE-CLASS-NAME . (DEBUG-ASSERT (EQ (CAR-SAFE ARG) 'LOCAL-REF)) (LET* ((MAP-VAR (GETF (VAR-DECLARATIONS (SECOND ARG)) 'MAPPING-TABLE)) (CLASS (VAR-DATA-TYPE (SECOND ARG))) NUMBER) (IF (NOT (DEBUG-ASSERT MAP-VAR NIL "No map associated with variable ~S." (VAR-NAME (SECOND ARG)))) (SETQ NUMBER 0) (SETQ NUMBER (DPB (SECOND (VAR-LAP-ADDRESS MAP-VAR)) SYS:%%CLOS-SELF-REF-MAPPING-TABLE-LOCAL-INDEX '#,(%LOGDPB 1 SYS:%%CLOS-SELF-REF-MAP-LEADER-FLAG (%LOGDPB 1 SYS:%%CLOS-SELF-REF-RELOCATE-FLAG (%LOGDPB 1 SYS:%%SELF-REF-TYPE-FLAG 0)))))) (VALUES NUMBER (TICLOS:TYPE-NAME CLASS) MAP-VAR))) (DEF SYS:%CLOS-MAP-REF) (DEFPROP SYS:%CLOS-MAP-REF (ARG NEW-CLASS) ARGLIST) (SETF (DOCUMENTATION 'SYS:%CLOS-MAP-REF) "Return mapping table for NEW-CLASS in ARG.") (DEFUN (:PROPERTY SYS:%CLOS-MAP-REF P2) (ARGL DEST) ;; 5/06/88 DNG - Original. (DESTRUCTURING-BIND (ARG NEW-CLASS) ARGL (MULTIPLE-VALUE-BIND (NUMBER CLASS-NAME MAP-VAR) (MAP-SPEC ARG) (IF (AND (QUOTEP NEW-CLASS) (EQ (SECOND NEW-CLASS) CLASS-NAME)) (P2 `(LOCAL-REF ,MAP-VAR) DEST) ; just pass along the current map (OUTI `(MOVE ,DEST (QUOTE-VECTOR (TICLOS:CLOS-VAR-POINTER ,NUMBER ',CLASS-NAME ,NEW-CLASS)))))))) (DEF SYS:%MAKE-CLOS-MAP-LIST) (DEFPROP SYS:%MAKE-CLOS-MAP-LIST (&REST ARGS-AND-CLASSES) ARGLIST) (SETF (DOCUMENTATION 'SYS:%MAKE-CLOS-MAP-LIST) "Returns a list [constructed at load time] of pointers to mapping tables. Example: (%MAKE-CLOS-MAP-LIST A1 'C1 A2 'C2) returns a list of two elements -- the map for class C1 in argument A1, and class C2 in A2.") (DEFUN (:PROPERTY SYS:%MAKE-CLOS-MAP-LIST P2) (ARGL DEST) ;; 5/06/88 DNG - Original. ;; 2/09/89 DNG - Special handling for classes T and T. (LET ((SPECS '())) (DO ((TAIL ARGL (CDDR TAIL))) ((NULL TAIL)) (LET ((ARG (FIRST TAIL)) (NEW-CLASS (EVAL (SECOND TAIL)))) (MULTIPLE-VALUE-BIND (NUMBER CLASS-NAME) (MAP-SPEC ARG) (PUSH (IF (AND (EQ CLASS-NAME T) (EQ NEW-CLASS T)) '(QUOTE (NIL NIL NIL)) ; tells CLOS-VAR-POINTER to return NIL `(QUOTE ,(LIST NUMBER CLASS-NAME NEW-CLASS))) SPECS) ))) (LET* ((FORM `(TICLOS:%CLOS-MAP-LIST . ,(NREVERSE SPECS)))) (OUTI `(MOVE ,DEST (QUOTE-VECTOR (QUOTE ,(CONS EVAL-AT-LOAD-TIME-MARKER FORM)))))))) (DEF SYS:%MAKE-CLOS-CONTINUATION-LIST) (DEFPROP SYS:%MAKE-CLOS-CONTINUATION-LIST ("E &REST METHODS-AND-MAPLISTS) ARGLIST) (SETF (DOCUMENTATION 'SYS:%MAKE-CLOS-CONTINUATION-LIST) "Returns a list [constructed at load time] of methods and mapping table lists. Example: (%MAKE-CLOS-CONTINUATION-LIST fspec1 (arg new1 old) fspec2 (arg new2 old)) The arguments are alternating function specs and map lists. Each map list is specified by an unevaluated list of argument name, new class, and old class.") (DEFF (:PROPERTY SYS:%MAKE-CLOS-CONTINUATION-LIST P1) #'IDENTITY) (DEFUN (:PROPERTY SYS:%MAKE-CLOS-CONTINUATION-LIST P2) (ARGL DEST) ;; 5/06/88 DNG - Original. ;; 2/09/89 DNG - Special handling for classes T and T. (LET ((RESULT '())) (DO ((CONT ARGL (CDDR CONT))) ((NULL CONT)) (debug-assert (or (function-spec-p (FIRST CONT)) (typep (FIRST CONT) 'compiled-function))) (PUSH (FIRST CONT) RESULT) ; function-spec of method (LET ((SPECS '())) (DO ((TAIL (SECOND CONT) (CDDDR TAIL))) ((NULL TAIL)) (LET ((VAR (LOOKUP-VAR (FIRST TAIL))) (NEW-CLASS (SECOND TAIL)) (FROM-CLASS (THIRD TAIL))) (debug-assert VAR nil "Invalid argument ~S in map list for ~S." (FIRST TAIL) 'SYS:%MAKE-CLOS-CONTINUATION-LIST) (MULTIPLE-VALUE-BIND (NUMBER CLASS-NAME) (MAP-SPEC `(LOCAL-REF ,VAR)) (PUSH (IF (AND (EQ FROM-CLASS T) (EQ NEW-CLASS T) (NOT (SUBTYPEP CLASS-NAME 'TICLOS:STANDARD-OBJECT))) '(NIL NIL NIL) ; tells CLOS-VAR-POINTER to return NIL (LIST NUMBER (OR FROM-CLASS CLASS-NAME) NEW-CLASS)) SPECS) ))) (PUSH (NREVERSE SPECS) RESULT) )) (LET* ((FORM `(TICLOS:%CLOS-CONTINUATION-LIST ',(NREVERSE RESULT)))) (OUTI `(MOVE ,DEST (QUOTE-VECTOR (QUOTE ,(CONS EVAL-AT-LOAD-TIME-MARKER FORM)))))))) (DEFUN (:PROPERTY %LOAD-TIME-VALUE P2) (ARGL DEST) (OUTI `(MOVE ,DEST (QUOTE-VECTOR (LOAD-TIME-VALUE . ,ARGL)))))