From: Guillermo J. Rozas Date: Tue, 3 Nov 1992 22:41:50 +0000 (+0000) Subject: Provide a new, faster version of apply. X-Git-Tag: 20090517-FFI~8808 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7e47830c7ecd1da5027bee510aa38249f74c5fa4;p=mit-scheme.git Provide a new, faster version of apply. --- diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 873448da2..5455648c5 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.31 1992/04/06 05:49:26 cph Exp $ +$Id: error.scm,v 14.32 1992/11/03 22:41:24 jinx Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -544,9 +544,9 @@ MIT in each case. |# (lambda (continuation) (let ((condition (apply make-condition - continuation - 'BOUND-RESTARTS - field-values))) + (cons* continuation + 'BOUND-RESTARTS + field-values)))) (signal-condition condition) (default-handler condition))))))) @@ -574,9 +574,9 @@ MIT in each case. |# (lambda (continuation) (let ((condition (apply make-condition - continuation - 'BOUND-RESTARTS - field-values))) + (cons* continuation + 'BOUND-RESTARTS + field-values)))) (bind-restart 'USE-VALUE (if (string? use-value-message) use-value-message @@ -662,7 +662,10 @@ MIT in each case. |# (define (initialize-package!) (set! hook/invoke-condition-handler default/invoke-condition-handler) - (set! hook/invoke-restart apply) + ;; No eta conversion for bootstrapping and efficiency reasons. + (set! hook/invoke-restart + (lambda (effector arguments) + (apply effector arguments))) (set! condition-type:serious-condition (make-condition-type 'SERIOUS-CONDITION false '() false)) (set! condition-type:warning diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index 814a7fb4e..d0a47eb1c 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: global.scm,v 14.42 1992/09/14 23:11:54 cph Exp $ +$Id: global.scm,v 14.43 1992/11/03 22:41:00 jinx Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -86,16 +86,9 @@ MIT in each case. |# (define (false-procedure . args) args false) (define (true-procedure . args) args true) -(define (apply f . args) - ((ucode-primitive apply) - f - (if (null? args) - '() - (let loop ((first-element (car args)) (rest-elements (cdr args))) - (if (null? rest-elements) - first-element - (cons first-element - (loop (car rest-elements) (cdr rest-elements)))))))) +;; This definition is replaced when the +;; later in the boot sequence. +(define apply (ucode-primitive apply 2)) (define (eval expression environment) (extended-scode-eval (syntax expression system-global-syntax-table) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index e9d380f97..949e94518 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.37 1992/10/17 22:23:18 jinx Exp $ +$Id: make.scm,v 14.38 1992/11/03 22:41:13 jinx Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -33,10 +33,16 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Make Runtime System +;;; package: () (declare (usual-integrations)) ((ucode-primitive set-interrupt-enables!) 0) + +;; This definition is replaced when the +;; later in the boot sequence. +(define apply (ucode-primitive apply 2)) + (define system-global-environment (the-environment)) (let ((environment-for-package (let () (the-environment)))) @@ -318,6 +324,7 @@ MIT in each case. |# ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES! #t) (RUNTIME STATE-SPACE) (RUNTIME MICROCODE-TABLES) + (RUNTIME APPLY) (RUNTIME PRIMITIVE-IO) (RUNTIME SAVE/RESTORE) (RUNTIME SYSTEM-CLOCK) diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm index 73cadffb1..cae42a8ec 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.18 1992/07/21 04:24:43 cph Exp $ +$Id: parse.scm,v 14.19 1992/11/03 22:41:30 jinx Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -94,7 +94,8 @@ MIT in each case. |# parse-object/special-undefined collect-list/special-undefined))) (for-each (lambda (entry) - (apply parser-table/set-entry! table entry)) + (apply parser-table/set-entry! + (cons table entry))) `(("#" ,parse-object/special ,collect-list/special) (,char-set/symbol-leaders ,parse-object/symbol) (("#b" "#B") ,parse-object/numeric-prefix) diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index e57ff8e4c..003ed565e 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.17 1992/02/08 15:08:39 cph Exp $ +$Id: syntax.scm,v 14.18 1992/11/03 22:41:38 jinx Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -179,13 +179,14 @@ MIT in each case. |# (define (syntax-error message . irritants) (apply error - (string-append "SYNTAX: " - (if *current-keyword* - (string-append (symbol->string *current-keyword*) - ": " - message) - message)) - irritants)) + (cons + (string-append "SYNTAX: " + (if *current-keyword* + (string-append (symbol->string *current-keyword*) + ": " + message) + message)) + irritants))) (define (syntax-expressions expressions) (if (null? expressions) @@ -446,7 +447,7 @@ MIT in each case. |# (define (syntax/define-macro pattern . body) (let ((keyword (car pattern))) (syntax-table-define *syntax-table* keyword - (syntax-eval (apply syntax/named-lambda pattern body))) + (syntax-eval (apply syntax/named-lambda (cons pattern body)))) keyword)) (define-integrable (syntax-eval scode) diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index 02f7f4cb0..700b605d7 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: uerror.scm,v 14.33 1992/10/21 00:17:23 jinx Exp $ +$Id: uerror.scm,v 14.34 1992/11/03 22:41:45 jinx Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -86,9 +86,9 @@ MIT in each case. |# (let ((make-condition (condition-constructor type field-names))) (lambda (continuation . field-values) (error (apply make-condition - continuation - 'BOUND-RESTARTS - field-values))))) + (cons* continuation + 'BOUND-RESTARTS + field-values)))))) ;;;; Restart Bindings @@ -424,7 +424,7 @@ MIT in each case. |# (fixed-objects-vector-slot 'ERROR-PROCEDURE) (lambda (datum arguments environment) environment - (apply error datum arguments))) + (apply error (cons* datum arguments)))) (vector-set! fixed-objects (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE) error) diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index c15a9925e..36395956a 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.12 1992/02/08 15:08:42 cph Exp $ +$Id: unsyn.scm,v 14.13 1992/11/03 22:41:50 jinx Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -102,8 +102,8 @@ MIT in each case. |# (define (unsyntax-error keyword message . irritants) (apply error - (string-append "UNSYNTAX: " (symbol->string keyword) ": " message) - irritants)) + (cons (string-append "UNSYNTAX: " (symbol->string keyword) ": " message) + irritants))) ;;;; Unsyntax Quanta diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm index 814a7fb4e..d0a47eb1c 100644 --- a/v8/src/runtime/global.scm +++ b/v8/src/runtime/global.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: global.scm,v 14.42 1992/09/14 23:11:54 cph Exp $ +$Id: global.scm,v 14.43 1992/11/03 22:41:00 jinx Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-1992 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -86,16 +86,9 @@ MIT in each case. |# (define (false-procedure . args) args false) (define (true-procedure . args) args true) -(define (apply f . args) - ((ucode-primitive apply) - f - (if (null? args) - '() - (let loop ((first-element (car args)) (rest-elements (cdr args))) - (if (null? rest-elements) - first-element - (cons first-element - (loop (car rest-elements) (cdr rest-elements)))))))) +;; This definition is replaced when the +;; later in the boot sequence. +(define apply (ucode-primitive apply 2)) (define (eval expression environment) (extended-scode-eval (syntax expression system-global-syntax-table) diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index e9d380f97..949e94518 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.37 1992/10/17 22:23:18 jinx Exp $ +$Id: make.scm,v 14.38 1992/11/03 22:41:13 jinx Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -33,10 +33,16 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Make Runtime System +;;; package: () (declare (usual-integrations)) ((ucode-primitive set-interrupt-enables!) 0) + +;; This definition is replaced when the +;; later in the boot sequence. +(define apply (ucode-primitive apply 2)) + (define system-global-environment (the-environment)) (let ((environment-for-package (let () (the-environment)))) @@ -318,6 +324,7 @@ MIT in each case. |# ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES! #t) (RUNTIME STATE-SPACE) (RUNTIME MICROCODE-TABLES) + (RUNTIME APPLY) (RUNTIME PRIMITIVE-IO) (RUNTIME SAVE/RESTORE) (RUNTIME SYSTEM-CLOCK)