From 04c91358aac845093bb287142ca8b33ee039aad7 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Wed, 11 Mar 1992 21:26:52 +0000 Subject: [PATCH] Added FDEFN changes. --- compiler/ir1tran.lisp | 30 +++++++-- compiler/ir2tran.lisp | 84 ++++++++--------------- compiler/ltn.lisp | 6 +- compiler/mips/alloc.lisp | 27 +++----- compiler/mips/call.lisp | 11 ++- compiler/mips/cell.lisp | 127 +++++++++++------------------------ compiler/mips/parms.lisp | 28 ++++---- compiler/mips/static-fn.lisp | 10 +-- compiler/mips/type-vops.lisp | 68 ++----------------- 9 files changed, 134 insertions(+), 257 deletions(-) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index add30c087..21dc8a555 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.66 1992/02/24 01:25:35 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.67 1992/03/11 21:23:26 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2470,14 +2470,30 @@ ;;; user policy settings. ;;; -(def-source-transform funcall (function &rest args) - `(%funcall ,function ,@args)) +(deftransform funcall ((function &rest args)) + (collect ((arg-names)) + (dolist (arg args) + (declare (ignore arg)) + (arg-names (gensym "FUNCALL-ARG-"))) + `(lambda (function ,@(arg-names)) + (%funcall ,(if (csubtypep (continuation-type function) + (specifier-type 'function)) + 'function + '(if (functionp function) + function + (%coerce-to-function function))) + ,@(arg-names))))) (def-ir1-translator %funcall ((function &rest args) start cont) (let ((fun-cont (make-continuation))) (ir1-convert start fun-cont function) + (assert-continuation-type fun-cont (specifier-type 'function)) (ir1-convert-combination-args fun-cont cont args))) +(deftransform %coerce-to-function ((thing)) + (give-up "Might be a symbol, so must call FDEFINITION at runtime.")) + + ;;;; Symbol macros: @@ -3106,7 +3122,13 @@ (node (if args (make-mv-combination fun-cont) (make-combination fun-cont)))) - (ir1-convert start fun-cont fun) + (ir1-convert start fun-cont + (if (and (consp fun) (eq (car fun) 'function)) + fun + (once-only ((fun fun)) + `(if (functionp ,fun) + ,fun + (%coerce-to-function ,fun))))) (setf (continuation-dest fun-cont) node) (assert-continuation-type fun-cont (specifier-type '(or function symbol))) diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp index 1c0bfe484..4f154b711 100644 --- a/compiler/ir2tran.lisp +++ b/compiler/ir2tran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.40 1991/12/19 22:11:50 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.41 1992/03/11 21:23:41 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -21,6 +21,9 @@ (export '(%caller-frame-and-pc)) (in-package "C") +(export '(safe-fdefn-function)) + + ;;;; Moves and type checks: @@ -122,26 +125,6 @@ (constant-tn (find-constant value))) -;;; IR2-Convert-Hairy-Function-Ref -- Internal -;;; -;;; Handle a function Ref that can't be converted to a symbol access. We -;;; convert a call to FDEFINITION with Name as the argument. -;;; -(defun ir2-convert-hairy-function-ref (node block name) - (declare (type ref node) (type ir2-block block) (type tn name)) - (when (policy node (> speed brevity)) - (let ((*compiler-error-context* node)) - (compiler-note "Compiling a full call to FDEFINITION."))) - (let* ((arg (standard-argument-location 0)) - (res (standard-argument-location 0)) - (fun (emit-constant 'fdefinition)) - (fp (make-stack-pointer-tn))) - (vop allocate-full-call-frame node block 1 fp) - (vop* call-named node block (fp fun name nil) (res nil) (list arg) 1 1) - (move-continuation-result node block (list res) (node-cont node))) - (undefined-value)) - - ;;; IR2-Convert-Ref -- Internal ;;; ;;; Convert a Ref node. The reference must not be delayed. @@ -170,22 +153,19 @@ (functional (ir2-convert-closure node block leaf res)) (global-var - (let ((name-tn (emit-constant name)) - (unsafe (policy node (zerop safety)))) + (let ((unsafe (policy node (zerop safety)))) (ecase (global-var-kind leaf) ((:special :global :constant) (assert (symbolp name)) - (if unsafe - (vop fast-symbol-value node block name-tn res) - (vop symbol-value node block name-tn res))) + (let ((name-tn (emit-constant name))) + (if unsafe + (vop fast-symbol-value node block name-tn res) + (vop symbol-value node block name-tn res)))) (:global-function - (unless (symbolp name) - (ir2-convert-hairy-function-ref node block name-tn) - (return-from ir2-convert-ref (undefined-value))) - - (if unsafe - (vop fast-symbol-function node block name-tn res) - (vop symbol-function node block name-tn res))))))) + (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) + (if unsafe + (vop fdefn-function node block fdefn-tn res) + (vop safe-fdefn-function node block fdefn-tn res)))))))) (move-continuation-result node block locs cont)) (undefined-value)) @@ -924,23 +904,19 @@ ;;; Function-Continuation-TN -- Internal ;;; -;;; Given a function continuation Fun, return as values a TN holding the -;;; thing that we call and true if the thing is a symbol (false if it is a -;;; function). There are three interesting non-symbol cases: +;;; Given a function continuation Fun, return as values a TN holding the +;;; thing that we call and true if the thing is named (false if it is a +;;; function). There are two interesting non-named cases: ;;; -- Known to be a function, no check needed: return the continuation loc. -;;; -- Known to be a function or a symbol, may need to be coerced. ;;; -- Not known what it is. ;;; (defun function-continuation-tn (node block cont) (declare (type continuation cont)) - (let* ((2cont (continuation-info cont)) - (name (if (eq (ir2-continuation-kind 2cont) :delayed) - (let ((res (continuation-function-name cont t))) - (assert res) - res) - nil))) - (if name - (values (emit-constant name) t) + (let ((2cont (continuation-info cont))) + (if (eq (ir2-continuation-kind 2cont) :delayed) + (let ((name (continuation-function-name cont t))) + (assert name) + (values (make-load-time-constant-tn :fdefinition name) t)) (let* ((locs (ir2-continuation-locs 2cont)) (loc (first locs)) (check (continuation-type-check cont)) @@ -958,17 +934,7 @@ (emit-type-check node block loc temp (specifier-type 'function))) (t - (when (policy node (> speed brevity)) - (let ((*compiler-error-context* node)) - (compiler-note - "Called function might be a ~ - symbol, so must coerce at run-time."))) - - (if (eq check t) - (vop coerce-to-function node block loc temp) - (vop fast-safe-coerce-to-function node block - loc temp)))) - + (error "This shouldn't happen."))) (values temp nil)))))))) @@ -1728,7 +1694,11 @@ (vop nil-function-returned-error last 2block (if name (emit-constant name) - (function-continuation-tn last 2block fun))))))) + (multiple-value-bind + (tn named) + (function-continuation-tn last 2block fun) + (assert (not named)) + tn))))))) ((not (eq (ir2-block-next 2block) (block-info target))) (vop branch last 2block (block-label target))))))) diff --git a/compiler/ltn.lisp b/compiler/ltn.lisp index 14a0cbfc7..28e3b26fb 100644 --- a/compiler/ltn.lisp +++ b/compiler/ltn.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ltn.lisp,v 1.30 1992/02/13 09:30:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ltn.lisp,v 1.31 1992/03/11 21:23:48 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -153,7 +153,7 @@ ;;; Annotate-Function-Continuation -- Internal ;;; ;;; Annotate the function continuation for a full call. If the only -;;; reference is to a global symbol function and Delay is true, then we delay +;;; reference is to a global function and Delay is true, then we delay ;;; the reference, otherwise we annotate for a single value. ;;; ;;; Unlike for an argument, we only clear the type check flag when the policy @@ -170,7 +170,7 @@ (info (make-ir2-continuation ptype))) (setf (continuation-info cont) info) (let ((name (continuation-function-name cont t))) - (if (and delay name (symbolp name)) + (if (and delay name) (setf (ir2-continuation-kind info) :delayed) (setf (ir2-continuation-locs info) (list (make-normal-tn ptype)))))) (undefined-value)) diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp index 06116d147..e8c033c4f 100644 --- a/compiler/mips/alloc.lisp +++ b/compiler/mips/alloc.lisp @@ -1,4 +1,4 @@ -;;; -*- Package: C -*- +;;; -*- Package: MIPS -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.15 1991/03/20 03:06:34 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.16 1992/03/11 21:26:13 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.15 1991/03/20 03:06:34 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.16 1992/03/11 21:26:13 wlott Exp $ ;;; ;;; Allocation VOPs for the MIPS port. ;;; @@ -108,24 +108,18 @@ (storew null-tn result vm:code-entry-points-slot vm:other-pointer-type) (storew null-tn result vm:code-debug-info-slot vm:other-pointer-type)))) -(define-vop (make-symbol) +(define-vop (make-fdefn) + (:policy :fast-safe) + (:translate make-fdefn) (:args (name :scs (descriptor-reg) :to :eval)) (:temporary (:scs (non-descriptor-reg)) temp) (:results (result :scs (descriptor-reg) :from :argument)) - (:policy :fast-safe) - (:translate make-symbol) (:generator 37 - (with-fixed-allocation (result temp vm:symbol-header-type vm:symbol-size) - (inst li temp vm:unbound-marker-type) - (storew temp result vm:symbol-value-slot vm:other-pointer-type) - (storew temp result vm:symbol-function-slot vm:other-pointer-type) - (storew temp result vm:symbol-setf-function-slot vm:other-pointer-type) + (with-fixed-allocation (result temp fdefn-type fdefn-size) + (storew name result fdefn-name-slot other-pointer-type) + (storew null-tn result fdefn-function-slot other-pointer-type) (inst li temp (make-fixup "undefined_tramp" :foreign)) - (storew temp result vm:symbol-raw-function-addr-slot - vm:other-pointer-type) - (storew null-tn result vm:symbol-plist-slot vm:other-pointer-type) - (storew name result vm:symbol-name-slot vm:other-pointer-type) - (storew null-tn result vm:symbol-package-slot vm:other-pointer-type)))) + (storew temp result fdefn-raw-addr-slot other-pointer-type)))) ;;;; Automatic allocators for primitive objects. @@ -133,7 +127,6 @@ (vm:define-for-each-primitive-object (obj) (collect ((forms)) (let* ((options (vm:primitive-object-options obj)) - (obj-type (getf options :type t)) (alloc-trans (getf options :alloc-trans)) (alloc-vop (getf options :alloc-vop alloc-trans)) (header (vm:primitive-object-header obj)) diff --git a/compiler/mips/call.lisp b/compiler/mips/call.lisp index 7d58fb822..29975bde3 100644 --- a/compiler/mips/call.lisp +++ b/compiler/mips/call.lisp @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.41 1991/11/09 20:52:53 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.42 1992/03/11 21:26:19 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.41 1991/11/09 20:52:53 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.42 1992/03/11 21:26:19 wlott Exp $ ;;; ;;; This file contains the VM definition of function call for the MIPS. ;;; @@ -805,17 +805,14 @@ default-value-8 (inst lw name-pass fp-tn (ash (tn-offset name) vm:word-shift)) (do-next-filler)) - (random-immediate - (load-symbol name-pass (tn-value name))) (constant (inst lw name-pass code-tn (- (ash (tn-offset name) vm:word-shift) vm:other-pointer-type)) (do-next-filler))) (inst lw lip name-pass - (- (ash vm:symbol-raw-function-addr-slot - vm:word-shift) - vm:other-pointer-type)) + (- (ash fdefn-raw-addr-slot word-shift) + other-pointer-type)) (do-next-filler)) `((sc-case arg-fun (descriptor-reg (move lexenv arg-fun)) diff --git a/compiler/mips/cell.lisp b/compiler/mips/cell.lisp index 471580f57..9d19c1902 100644 --- a/compiler/mips/cell.lisp +++ b/compiler/mips/cell.lisp @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.56 1992/02/24 00:43:42 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.57 1992/03/11 21:26:25 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.56 1992/02/24 00:43:42 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.57 1992/03/11 21:26:25 wlott Exp $ ;;; ;;; This file contains the VM definition of various primitive memory access ;;; VOPs for the MIPS. @@ -105,27 +105,6 @@ (inst beq temp zero-tn err-lab) (inst nop)))) -;;; With Symbol-Function, we check that the result is a function, so NIL is -;;; always un-fbound. -;;; -(define-vop (symbol-function checked-cell-ref) - (:translate symbol-function) - (:generator 10 - (move obj-temp object) - (loadw value obj-temp symbol-function-slot other-pointer-type) - (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) - (test-simple-type value temp err-lab t function-pointer-type)))) - -#+nil -(define-vop (symbol-setf-function checked-cell-ref) - (:translate symbol-setf-function) - (:generator 10 - (move obj-temp object) - (loadw value obj-temp symbol-setf-function-slot other-pointer-type) - (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) - (test-simple-type value temp err-lab t function-pointer-type)))) - - ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. (define-vop (boundp-frob) (:args (object :scs (descriptor-reg))) @@ -145,55 +124,37 @@ (inst bne temp zero-tn target)) (inst nop))) - -;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction -;;; on the symbol case of fboundp. Instead, we transform to a funny function. - -(defknown fboundp/symbol (t) boolean (flushable)) -;;; -(deftransform fboundp ((x) (symbol)) - '(fboundp/symbol x)) -;;; -(define-vop (fboundp/symbol boundp-frob) - (:translate fboundp/symbol) - (:generator 10 - (loadw value object symbol-function-slot other-pointer-type) - (test-simple-type value temp target not-p function-pointer-type))) - -#+nil(progn -(defknown fboundp/setf (t) boolean (flushable)) -;;; -(deftransform fboundp ((x) (cons)) - '(fboundp/setf (cadr x))) -;;; -(define-vop (fboundp/setf boundp-frob) - (:translate fboundp/setf) - (:generator 10 - (loadw value object symbol-setf-function-slot other-pointer-type) - (test-simple-type value temp target not-p function-pointer-type))) -) - (define-vop (fast-symbol-value cell-ref) (:variant symbol-value-slot other-pointer-type) (:policy :fast) (:translate symbol-value)) -(define-vop (fast-symbol-function cell-ref) - (:variant symbol-function-slot other-pointer-type) - (:policy :fast) - (:translate symbol-function)) -(define-vop (set-symbol-function) - (:translate %set-symbol-function) + +;;;; Fdefinition (fdefn) objects. + +(define-vop (safe-fdefn-function) + (:args (object :scs (descriptor-reg) :target obj-temp)) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp) + (:generator 10 + (move obj-temp object) + (loadw value obj-temp fdefn-function-slot other-pointer-type) + (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) + (inst beq value null-tn err-lab)) + (inst nop))) + +(define-vop (set-fdefn-function) (:policy :fast-safe) - (:args (symbol :scs (descriptor-reg)) - (function :scs (descriptor-reg) :target result)) - (:results (result :scs (descriptor-reg))) + (:translate (setf fdefn-function)) + (:args (function :scs (descriptor-reg) :target result) + (fdefn :scs (descriptor-reg))) + (:temporary (:scs (interior-reg)) lip) (:temporary (:scs (non-descriptor-reg)) type) - (:temporary (:scs (any-reg)) temp) - (:save-p :compute-only) - (:vop-var vop) - (:generator 30 + (:results (result :scs (descriptor-reg))) + (:generator 38 (let ((closure (gen-label)) (normal-fn (gen-label))) (load-type type function (- function-pointer-type)) @@ -205,40 +166,32 @@ (inst beq type zero-tn closure) (inst xor type (logxor funcallable-instance-header-type function-header-type)) - (inst beq type zero-tn normal-fn) - (inst addu temp function + (inst bne type zero-tn normal-fn) + (inst addu lip function (- (ash function-header-code-offset word-shift) function-pointer-type)) - (error-call vop kernel:object-not-function-error function) (emit-label closure) - (inst li temp (make-fixup "closure_tramp" :foreign)) + (inst li lip (make-fixup "closure_tramp" :foreign)) (emit-label normal-fn) - (storew function symbol symbol-function-slot other-pointer-type) - (storew temp symbol symbol-raw-function-addr-slot other-pointer-type) + (storew function fdefn fdefn-function-slot other-pointer-type) + (storew lip fdefn fdefn-raw-addr-slot other-pointer-type) (move result function)))) - -(defknown fmakunbound/symbol (symbol) symbol (unsafe)) -;;; -(deftransform fmakunbound ((symbol) (symbol)) - '(when symbol - (fmakunbound/symbol symbol))) -;;; -(define-vop (fmakunbound/symbol) - (:translate fmakunbound/symbol) +(define-vop (fdefn-makunbound) (:policy :fast-safe) - (:args (symbol :scs (descriptor-reg) :target result)) - (:results (result :scs (descriptor-reg))) + (:translate fdefn-makunbound) + (:args (fdefn :scs (descriptor-reg) :target result)) (:temporary (:scs (non-descriptor-reg)) temp) - (:generator 5 - (inst li temp unbound-marker-type) - (storew temp symbol symbol-function-slot other-pointer-type) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (storew null-tn fdefn fdefn-function-slot other-pointer-type) (inst li temp (make-fixup "undefined_tramp" :foreign)) - (storew temp symbol symbol-raw-function-addr-slot other-pointer-type) - (move result symbol))) + (storew temp fdefn fdefn-raw-addr-slot other-pointer-type) + (move result fdefn))) -;;; Binding and Unbinding. + +;;;; Binding and Unbinding. ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and ;;; the symbol on the binding stack and stuff the new value into the diff --git a/compiler/mips/parms.lisp b/compiler/mips/parms.lisp index d547b4cd5..7412f58b2 100644 --- a/compiler/mips/parms.lisp +++ b/compiler/mips/parms.lisp @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.99 1992/02/14 23:50:29 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.100 1992/03/11 21:26:44 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.99 1992/02/14 23:50:29 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.100 1992/03/11 21:26:44 wlott Exp $ ;;; ;;; This file contains some parameterizations of various VM ;;; attributes for the MIPS. This file is separate from other stuff so @@ -42,7 +42,7 @@ (setf (backend-fasl-file-type *target-backend*) "pmaxf") (setf (backend-fasl-file-implementation *target-backend*) pmax-fasl-file-implementation) -(setf (backend-fasl-file-version *target-backend*) 3) +(setf (backend-fasl-file-version *target-backend*) 4) (setf (backend-register-save-penalty *target-backend*) 3) (setf (backend-byte-order *target-backend*) :little-endian) @@ -152,14 +152,15 @@ ;;;; Static symbols. -(export '(static-symbols exported-static-symbols)) +(export '(static-symbols static-functions)) -;;; These symbols are loaded into static space directly after NIL so +;;; Static symbols are loaded into static space directly after NIL so ;;; that the system can compute their address by adding a constant ;;; amount to NIL. ;;; -;;; The exported static symbols are a subset of the static symbols that get -;;; exported to the C header file. +;;; The fdefn objects for the static functions are loaded into static +;;; space directly after the static symbols. That way, the raw-addr +;;; can be loaded directly out of them by indirecting relative to NIL. ;;; (defparameter static-symbols '(t @@ -167,12 +168,14 @@ ;; Random stuff needed for initialization. lisp::lisp-environment-list lisp::lisp-command-line-list + lisp::*initial-fdefn-objects* ;; Functions that the C code needs to call lisp::%initial-function lisp::maybe-gc kernel::internal-error di::handle-breakpoint + lisp::fdefinition-object ;; Free Pointers lisp::*read-only-space-free-pointer* @@ -188,13 +191,10 @@ lisp::*free-interrupt-context-index* unix::*interrupts-enabled* unix::*interrupt-pending* + )) - ;; Static functions. - two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= +(defparameter static-functions + '(two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= two-arg-<= two-arg->= two-arg-/= eql %negate two-arg-and two-arg-ior two-arg-xor - length two-arg-gcd two-arg-lcm - )) - -(defparameter exported-static-symbols - (subseq static-symbols 0 (position 'two-arg-+ static-symbols))) + length two-arg-gcd two-arg-lcm)) diff --git a/compiler/mips/static-fn.lisp b/compiler/mips/static-fn.lisp index 8ac396194..b3658aef1 100644 --- a/compiler/mips/static-fn.lisp +++ b/compiler/mips/static-fn.lisp @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.15 1991/07/14 03:46:41 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.16 1992/03/11 21:26:48 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.15 1991/07/14 03:46:41 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/static-fn.lisp,v 1.16 1992/03/11 21:26:48 wlott Exp $ ;;; ;;; This file contains the VOPs and macro magic necessary to call static ;;; functions. @@ -30,7 +30,6 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (descriptor-reg)) move-temp) (:temporary (:sc descriptor-reg :offset lra-offset) lra) - (:temporary (:sc descriptor-reg :offset cname-offset) cname) (:temporary (:scs (interior-reg) :type interior) lip) (:temporary (:sc any-reg :offset nargs-offset) nargs) (:temporary (:sc any-reg :offset ocfp-offset) old-fp) @@ -92,10 +91,7 @@ (cur-nfp (current-nfp-tn vop))) ,@(moves (temp-names) (arg-names)) (inst li nargs (fixnum ,num-args)) - (load-symbol cname symbol) - (inst lw lip cname - (- (ash vm:symbol-raw-function-addr-slot vm:word-shift) - vm:other-pointer-type)) + (inst lw lip null-tn (static-function-offset symbol)) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) (inst move old-fp cfp-tn) diff --git a/compiler/mips/type-vops.lisp b/compiler/mips/type-vops.lisp index fef2cd2f6..a55cc50de 100644 --- a/compiler/mips/type-vops.lisp +++ b/compiler/mips/type-vops.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.32 1991/11/09 02:37:45 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.33 1992/03/11 21:26:52 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -150,12 +150,18 @@ (:variant-cost 9) (:translate lra-p)) +(define-vop (fdefn-p simple-type-predicate) + (:variant fdefn-type) + (:variant-cost 9) + (:translate fdefn-p)) + (define-vop (scavenger-hook-p simple-type-predicate) (:variant 0) (:variant-cost 9) (:translate scavenger-hook-p)) + ;;; Slightly tenser versions for FIXNUM's ;;; (define-vop (check-fixnum check-simple-type) @@ -469,63 +475,3 @@ (test-simple-type obj temp target not-p vm:list-pointer-type) (emit-label drop-thru)))) - -;;;; Function Coercion - -;;; If not a function, get the symbol value and test for that being a -;;; function. Since we test for a function rather than the unbound -;;; marker, this works on NIL. -;;; -(define-vop (coerce-to-function) - (:args (object :scs (descriptor-reg) - :target result)) - (:results (result :scs (descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) nd-temp) - (:temporary (:scs (descriptor-reg)) saved-object) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (let ((not-function-label (gen-label)) - (not-coercable-label (gen-label)) - (done-label (gen-label))) - (test-simple-type object nd-temp not-function-label t - vm:function-pointer-type) - (move result object) - (emit-label done-label) - - (assemble (*elsewhere*) - (emit-label not-function-label) - (test-simple-type object nd-temp not-coercable-label t - vm:symbol-header-type) - (move saved-object object) - (loadw result object vm:symbol-function-slot vm:other-pointer-type) - (test-simple-type result nd-temp done-label nil - vm:function-pointer-type) - (error-call vop undefined-symbol-error saved-object) - - (emit-label not-coercable-label) - (error-call vop object-not-coercable-to-function-error object))))) - -(define-vop (fast-safe-coerce-to-function) - (:args (object :scs (descriptor-reg) - :target result)) - (:results (result :scs (descriptor-reg))) - (:temporary (:type random :scs (non-descriptor-reg)) nd-temp) - (:temporary (:scs (descriptor-reg)) saved-object) - (:vop-var vop) - (:save-p :compute-only) - (:generator 0 - (let ((not-function-label (gen-label)) - (done-label (gen-label))) - (test-simple-type object nd-temp not-function-label t - vm:function-pointer-type) - (move result object) - (emit-label done-label) - - (assemble (*elsewhere*) - (emit-label not-function-label) - (move saved-object object) - (loadw result object vm:symbol-function-slot vm:other-pointer-type) - (test-simple-type result nd-temp done-label nil - vm:function-pointer-type) - (error-call vop undefined-symbol-error saved-object))))) -- GitLab