#| -*-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
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))
\f
-;; 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? <object>)
-;; (%compiled-entry-maximum-arity? <arity+1> <object>)
-
-(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)
projects / mit-scheme.git / commitdiff