From 729f7a67475193672fb48465de278fd9ba4848cf Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Fri, 26 Jul 1996 19:57:38 +0000 Subject: [PATCH] Reorganized and extended code. --- v8/src/runtime/coerce.scm | 295 +++++++++++++++++++------------------- 1 file changed, 149 insertions(+), 146 deletions(-) diff --git a/v8/src/runtime/coerce.scm b/v8/src/runtime/coerce.scm index 52242538e..7cd953f31 100644 --- a/v8/src/runtime/coerce.scm +++ b/v8/src/runtime/coerce.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: coerce.scm,v 1.3 1996/07/26 14:58:45 adams Exp $ +$Id: coerce.scm,v 1.4 1996/07/26 19:57:38 adams Exp $ Copyright (c) 1996 Massachusetts Institute of Technology @@ -32,185 +32,188 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Coerce-to-compiled-procedure +;;;; COERCE-TO-COMPILED-PROCEDURE ;;; package: (runtime coerce-to-compiled-procedure) ;; This file must be syntaxed with the 8.0 compiler loaded (declare (usual-integrations)) -;; COERCE-TO-COMPILED-PROCEDURE -;; -;; This code is special. It uses several hooks into the 8.0 compiler in -;; order to generate efficient code. Care has to be taken to ensure -;; that none of the compiled code uses COERCE-TO-COMPILED-PROCEDURE, -;; otherwise we would have a loop. -;; - +;; This code is special. It `hooks' into the 8.0 compiler's +;; representation generate an unchecked call, which is necessary for +;; calling procedures with listified rest args. We also use +;; vector-8b-ref on the procedure to get the arity info. As this is +;; on the critical path, calling a primitive just is not fast enough. +;; Care has to be taken to ensure that none of the compiled code uses +;; COERCE-TO-COMPILED-PROCEDURE, otherwise we would have a loop. (define-macro (special-operator name) `(QUOTE ,(environment-lookup (->environment '(COMPILER MIDEND)) name))) -(define-macro (%funcall procedure . arguments) - `((special-operator %internal-apply-unchecked) - ,(+ (length arguments) 1) - ,procedure - ,@arguments)) - -;; (%compiled-entry? ) -;; (%compiled-entry-maximum-arity? ) - -(define-integrable %compiled-entry? (special-operator %compiled-entry?)) - -(define-integrable %compiled-entry-maximum-arity? - (special-operator %compiled-entry-maximum-arity?)) - (define (coerce-to-compiled-procedure/compiled object arity) - (let ((xx ((lambda (#!optional xx) xx))) - (+ fix:+) - (= fix:=) - (< fix:<)) + ;; XX and JUMP are in the let. This is sufficiently obscure that SF + ;; leaves the code looking nice if we pp a coercion procedure, but + ;; not sufficiently obscure that the compiler generates wrong (if + ;; JUMP were not integrated) or inefficent (if XX were not + ;; integrated) code. - (define (use-microcode) - ((ucode-primitive coerce-to-compiled-procedure 2) object arity)) + (let ((xx ((lambda (#!optional xx) xx))) ; compute default-object + (jump (special-operator %internal-apply-unchecked))) (define (default) - (use-microcode)) + ((ucode-primitive coerce-to-compiled-procedure 2) object arity)) + + (define-integrable (entity-extra entity) + (system-pair-cdr entity)) + + (define-integrable (entity-procedure entity) + (system-pair-car entity)) + + (define (try-arity-dispatched-procedure) + (cond ((and (fix:> (vector-length (entity-extra object)) arity) + (vector-ref (entity-extra object) (fix:+ arity 1))) + => (lambda (dispatched-procedure) + (coerce-to-compiled-procedure dispatched-procedure arity))) + (else + (default)))) + + (define (try-other-representations) + (cond ((and (object-type? (ucode-type entity) object) + (vector? (entity-extra object)) + (eq? (vector-ref (entity-extra object) 0) + arity-dispatcher-tag)) + (try-arity-dispatched-procedure)) + ((object-type? (ucode-type primitive) object) + (make-primitive-coercion object arity)) + (else + (default)))) (define (mismatch) - (use-microcode)) + (default)) + + (define (make-compiled-coercion procedure arity min max) + ;; Note that min and max are +1-encoded, arity is not. + + (define-macro (coerce args . exprs) + `(NAMED-LAMBDA (PROCEDURE-COERCION ,@args) + (JUMP ,(+ (length exprs) 1) PROCEDURE ,@exprs))) - (define (make-trampoline f arity min max) (cond - ((= min max) + ((fix:= min max) + (mismatch)) + ((fix:<= arity min) (mismatch)) - ((< max 128) + (else (case arity - ((1) + ((0) ; min = 1 (case max - ((2) (lambda () (%funcall f xx))) - ((3) (lambda () (%funcall f xx xx))) - ((4) (lambda () (%funcall f xx xx xx))) - ((5) (lambda () (%funcall f xx xx xx xx))) + ((2) (coerce () xx)) + ((3) (coerce () xx xx)) + ((4) (coerce () xx xx xx)) + ((5) (coerce () xx xx xx xx)) + ((254) (coerce () '())) + ((253) (coerce () xx '())) + ((252) (coerce () xx xx '())) + ((251) (coerce () xx xx xx '())) + ((250) (coerce () xx xx xx xx '())) (else (default)))) - ((2) + ((1) ; min <= 2 (case max - ((3) (lambda (a1) (%funcall f a1 xx))) - ((4) (lambda (a1) (%funcall f a1 xx xx))) - ((5) (lambda (a1) (%funcall f a1 xx xx xx))) + ((3) (coerce (a1) a1 xx)) + ((4) (coerce (a1) a1 xx xx)) + ((5) (coerce (a1) a1 xx xx xx)) + ((254) (coerce (a1) (list a1))) + ((253) (coerce (a1) a1 '())) + ((252) (coerce (a1) a1 xx '())) + ((251) (coerce (a1) a1 xx xx '())) + ((250) (coerce (a1) a1 xx xx xx '())) (else (default)))) - ((3) + ((2) ; min <= 3 (case max - ((4) (lambda (a1 a2) (%funcall f a1 a2 xx))) - ((5) (lambda (a1 a2) (%funcall f a1 a2 xx xx))) + ((4) (coerce (a1 a2) a1 a2 xx)) + ((5) (coerce (a1 a2) a1 a2 xx xx)) + ((254) (coerce (a1 a2) (list a1 a2))) + ((253) (coerce (a1 a2) a1 (list a2))) + ((252) (coerce (a1 a2) a1 a2 '())) + ((251) (coerce (a1 a2) a1 a2 xx '())) + ((250) (coerce (a1 a2) a1 a2 xx xx '())) (else (default)))) - ((4) + ((3) ; min <= 4 + (case max + ((5) (coerce (a1 a2 a3) a1 a2 a3 xx)) + ((254) (coerce (a1 a2 a3) (list a1 a2 a3))) + ((253) (coerce (a1 a2 a3) a1 (list a2 a3))) + ((252) (coerce (a1 a2 a3) a1 a2 (list a3))) + ((251) (coerce (a1 a2 a3) a1 a2 a3 '())) + ((250) (coerce (a1 a2 a3) a1 a2 a3 xx '())) + (else (default)))) + ((4) ; min <= 5 + (case max + ((254) (coerce (a1 a2 a3 a4) (list a1 a2 a3 a4))) + ((253) (coerce (a1 a2 a3 a4) a1 (list a2 a3 a4))) + ((252) (coerce (a1 a2 a3 a4) a1 a2 (list a3 a4))) + ((251) (coerce (a1 a2 a3 a4) a1 a2 a3 (list a4))) + ((250) (coerce (a1 a2 a3 a4) a1 a2 a3 a4 '())))) + ((5) ; min <= 6 (case max - ((5) (lambda (a1 a2 a3) (%funcall f a1 a2 a3 xx))) + ((254) (coerce (a1 a2 a3 a4 a5) (list a1 a2 a3 a4 a5))) + ((253) (coerce (a1 a2 a3 a4 a5) a1 (list a2 a3 a4 a5))) + ((252) (coerce (a1 a2 a3 a4 a5) a1 a2 (list a3 a4 a5))) + ((251) (coerce (a1 a2 a3 a4 a5) a1 a2 a3 (list a4 a5))) + ((250) (coerce (a1 a2 a3 a4 a5) a1 a2 a3 a4 (list a5))) (else (default)))) - (else (default)))) - (else;; max >= 128 - (make-listifying-trampoline f arity min max)))) - - (define (make-listifying-trampoline f arity min max) - (case arity - ((1) - (case min - ((1) - (case max - ((254) (lambda () (%funcall f '()))) - ((253) (lambda () (%funcall f xx '()))) - ((252) (lambda () (%funcall f xx xx '()))) - ((251) (lambda () (%funcall f xx xx xx '()))) - ((250) (lambda () (%funcall f xx xx xx xx '()))) - (else (default)))) - (else (default)))) - ((2) - (if (< (+ min max) 256) - (case max - ((254) (lambda (a1) (%funcall f (list a1)))) - ((253) (lambda (a1) (%funcall f a1 '()))) - ((252) (lambda (a1) (%funcall f a1 xx '()))) - ((251) (lambda (a1) (%funcall f a1 xx xx '()))) - ((250) (lambda (a1) (%funcall f a1 xx xx xx '()))) - (else (default))) - (default))) - ((3) - (if (< (+ min max) 256) - (case max - ((254) (lambda (a1 a2) (%funcall f (list a1 a2)))) - ((253) (lambda (a1 a2) (%funcall f a1 (list a2)))) - ((252) (lambda (a1 a2) (%funcall f a1 a2 '()))) - ((251) (lambda (a1 a2) (%funcall f a1 a2 xx '()))) - ((250) (lambda (a1 a2) (%funcall f a1 a2 xx xx '()))) - (else (default))) - (default))) - ((4) - (if (< (+ min max) 256) - (case max - ((254) (lambda (a1 a2 a3) (%funcall f (list a1 a2 a3)))) - ((253) (lambda (a1 a2 a3) (%funcall f a1 (list a2 a3)))) - ((252) (lambda (a1 a2 a3) (%funcall f a1 a2 (list a3)))) - ((251) (lambda (a1 a2 a3) (%funcall f a1 a2 a3 '()))) - ((250) (lambda (a1 a2 a3) (%funcall f a1 a2 a3 xx '()))) - (else (default))) - (default))) - ((5) - (if (< (+ min max) 256) - (case max - ((254) (lambda (a1 a2 a3 a4) (%funcall f (list a1 a2 a3 a4)))) - ((253) (lambda (a1 a2 a3 a4) (%funcall f a1 (list a2 a3 a4)))) - ((252) (lambda (a1 a2 a3 a4) (%funcall f a1 a2 (list a3 a4)))) - ((251) (lambda (a1 a2 a3 a4) (%funcall f a1 a2 a3 (list a4)))) - ((250) (lambda (a1 a2 a3 a4) (%funcall f a1 a2 a3 a4 '()))) - (else (default))) - (default))) - ((6) - (if (< (+ min max) 256) - (case max - ((254) (lambda (a1 a2 a3 a4 a5) - (%funcall f (list a1 a2 a3 a4 a5)))) - ((253) (lambda (a1 a2 a3 a4 a5) - (%funcall f a1 (list a2 a3 a4 a5)))) - ((252) (lambda (a1 a2 a3 a4 a5) - (%funcall f a1 a2 (list a3 a4 a5)))) - ((251) (lambda (a1 a2 a3 a4 a5) - (%funcall f a1 a2 a3 (list a4 a5)))) - ((250) (lambda (a1 a2 a3 a4 a5) - (%funcall f a1 a2 a3 a4 (list a5)))) - (else (default))) - (default))) - (else (default)))) - - (if (and (%compiled-entry? object) - (fixnum? arity)) - (if (and (%compiled-entry-maximum-arity? arity object) - (< arity 128)) - object - (let ((info ((ucode-primitive compiled-entry-kind 1) object))) - ;; max = (-1)^tail? * (1 + req + opt + tail?) - ;; min = (1 + req) - (let ((min (system-hunk3-cxr1 info)) - (max (system-hunk3-cxr2 info))) - (make-trampoline object arity min max)))) - (use-microcode)))) - - -(define (%compiled-entry-arity p) - (let ((info ((ucode-primitive compiled-entry-kind 1) p))) - ;; max = (-1)^tail? * (1 + req + opt + tail?) - ;; min = (1 + req) - (let ((min (system-hunk3-cxr1 info)) - (max (system-hunk3-cxr2 info))) - (cons min max)))) - -;;(define coerce-to-compiled-procedure) + ((6) ; min <= 7 + (case max + ((254) (coerce (a1 a2 a3 a4 a5 a6) (list a1 a2 a3 a4 a5 a6))) + ((253) (coerce (a1 a2 a3 a4 a5 a6) a1 (list a2 a3 a4 a5 a6))) + ((252) (coerce (a1 a2 a3 a4 a5 a6) a1 a2 (list a3 a4 a5 a6))) + (else (default)))) + (else (default)))))) + + (if (fixnum? arity) + (if (object-type? (ucode-type compiled-entry) object) + (let ((min (vector-8b-ref object -12)) + (max (vector-8b-ref object -11))) + (if (< min 128) ; i.e. procedure, not continuation etc. + (if (= (- max 1) arity) + object ; the path to here is critical + (make-compiled-coercion object arity min max)) + (default))) + (try-other-representations)) + (default)))) + + +(define (make-primitive-coercion primitive arity) + (cond ((and (eq? primitive (ucode-primitive car)) (eqv? arity 1)) + (named-lambda (car object) + (if (pair? object) + (car object) + (error:wrong-type-argument object "pair" 'CAR)))) + (else + ((ucode-primitive coerce-to-compiled-procedure 2) + primitive arity)))) + + + +(define arity-dispatcher-tag + (string->symbol "#[(microcode)arity-dispatcher-tag]")) + +(declare (ignore-reference-traps (set arity-dispatcher-tag))) + + +;; This is done in make.scm: (define coerce-to-compiled-procedure) (define (initialize-package!) + ;; The above code only works if compiled, so just use the primitive if + ;; this file is not compiled. (set! coerce-to-compiled-procedure (if (compiled-procedure? coerce-to-compiled-procedure/compiled) coerce-to-compiled-procedure/compiled (ucode-primitive coerce-to-compiled-procedure))) + + ;; (set! arity-dispatcher-tag (fixed-objects-item 'ARITY-DISPATCHER-TAG)) + (set! arity-dispatcher-tag (vector-ref (get-fixed-objects-vector) 33)) + unspecific) -- 2.25.1