From: Chris Hanson Date: Thu, 16 Aug 2012 06:48:36 +0000 (-0700) Subject: Remove alternate/optimized types of scode combinations from runtime. X-Git-Tag: release-9.2.0~231 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3fc580e;p=mit-scheme.git Remove alternate/optimized types of scode combinations from runtime. --- diff --git a/src/compiler/fggen/canon.scm b/src/compiler/fggen/canon.scm index 8b376f215..dae64f82d 100644 --- a/src/compiler/fggen/canon.scm +++ b/src/compiler/fggen/canon.scm @@ -867,12 +867,7 @@ ARBITRARY: The expression may be executed more than once. It (binary-entry disjunction) (standard-entry variable) (standard-entry the-environment) - (dispatch-entries (combination-1 combination-2 combination - primitive-combination-0 - primitive-combination-1 - primitive-combination-2 - primitive-combination-3) - canonicalize/combination) + (dispatch-entry combination canonicalize/combination) (dispatch-entries (lambda lexpr extended-lambda) canonicalize/lambda) (dispatch-entry sequence-2 canonicalize/sequence)) (named-lambda (canonicalize/expression expression bound context) diff --git a/src/compiler/fggen/fggen.scm b/src/compiler/fggen/fggen.scm index 32c8eb946..9ce8396e7 100644 --- a/src/compiler/fggen/fggen.scm +++ b/src/compiler/fggen/fggen.scm @@ -991,12 +991,7 @@ USA. (standard-entry variable) (dispatch-entries (lambda lexpr extended-lambda) generate/lambda) (dispatch-entry sequence-2 generate/sequence) - (dispatch-entries (combination-1 combination-2 combination - primitive-combination-0 - primitive-combination-1 - primitive-combination-2 - primitive-combination-3) - generate/combination) + (dispatch-entry combination generate/combination) (dispatch-entry comment generate/comment)) (named-lambda (generate/expression block continuation context expression) ((vector-ref dispatch-vector (object-type expression)) diff --git a/src/runtime/codwlk.scm b/src/runtime/codwlk.scm index 396b41cc9..92342fc0e 100644 --- a/src/runtime/codwlk.scm +++ b/src/runtime/codwlk.scm @@ -111,14 +111,7 @@ USA. (kernel (car entry))))) `((ACCESS ,walk/access) (ASSIGNMENT ,walk/assignment) - ((COMBINATION - COMBINATION-1 - COMBINATION-2 - PRIMITIVE-COMBINATION-0 - PRIMITIVE-COMBINATION-1 - PRIMITIVE-COMBINATION-2 - PRIMITIVE-COMBINATION-3) - ,walk/combination) + (COMBINATION ,walk/combination) (COMMENT ,walk/comment) (CONDITIONAL ,walk/conditional) (DEFINITION ,walk/definition) diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm index 5ff34ebf2..02f233bbc 100644 --- a/src/runtime/conpar.scm +++ b/src/runtime/conpar.scm @@ -806,20 +806,11 @@ USA. (standard-subproblem 'ACCESS-CONTINUE 2) (standard-subproblem 'ASSIGNMENT-CONTINUE 3) - (standard-subproblem 'COMBINATION-1-PROCEDURE 3) - (standard-subproblem 'COMBINATION-2-FIRST-OPERAND 3) - (standard-subproblem 'COMBINATION-2-PROCEDURE 4) (standard-subproblem 'CONDITIONAL-DECIDE 3) (standard-subproblem 'DEFINITION-CONTINUE 3) (standard-subproblem 'DISJUNCTION-DECIDE 3) (standard-subproblem 'EVAL-ERROR 3) (standard-subproblem 'FORCE-SNAP-THUNK 2) - (standard-subproblem 'PRIMITIVE-COMBINATION-1-APPLY 2) - (standard-subproblem 'PRIMITIVE-COMBINATION-2-APPLY 3) - (standard-subproblem 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND 3) - (standard-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 4) - (standard-subproblem 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND 4) - (standard-subproblem 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND 3) (standard-subproblem 'SEQUENCE-2-SECOND 3) (standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value) diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm index 941bee16c..9f17a15bc 100644 --- a/src/runtime/framex.scm +++ b/src/runtime/framex.scm @@ -115,12 +115,6 @@ USA. undefined-environment (validate-subexpression frame (select-subexpression expression))))) -(define (method/primitive-combination-3-first-operand frame) - (let ((expression (stack-frame/ref frame 1))) - (values expression - (stack-frame/ref frame 3) - (validate-subexpression frame (&vector-ref expression 2))))) - (define (method/combination-save-value frame) (let ((expression (stack-frame/ref frame 1))) (values expression @@ -276,28 +270,12 @@ USA. (record-method 'SEQUENCE-2-SECOND method)) (let ((method (method/standard &pair-cdr))) (record-method 'ASSIGNMENT-CONTINUE method) - (record-method 'COMBINATION-1-PROCEDURE method) (record-method 'DEFINITION-CONTINUE method)) (let ((method (method/standard &triple-first))) (record-method 'CONDITIONAL-DECIDE method)) - (let ((method (method/standard &triple-second))) - (record-method 'COMBINATION-2-PROCEDURE method)) - (let ((method (method/standard &triple-third))) - (record-method 'COMBINATION-2-FIRST-OPERAND method) - (record-method 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND method)) - (record-method 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND - (method/standard &vector-fourth)) (let ((method (method/expression-only &pair-car))) (record-method 'ACCESS-CONTINUE method)) - (record-method 'PRIMITIVE-COMBINATION-1-APPLY - (method/expression-only &pair-cdr)) - (record-method 'PRIMITIVE-COMBINATION-2-APPLY - (method/expression-only &triple-second)) - (record-method 'PRIMITIVE-COMBINATION-3-APPLY - (method/expression-only &vector-second)) (record-method 'COMBINATION-SAVE-VALUE method/combination-save-value) - (record-method 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND - method/primitive-combination-3-first-operand) (record-method 'EVAL-ERROR method/eval-error) (record-method 'FORCE-SNAP-THUNK method/force-snap-thunk) (let ((method (method/application-frame 3))) diff --git a/src/runtime/scomb.scm b/src/runtime/scomb.scm index 6d466552c..ebf03b6be 100644 --- a/src/runtime/scomb.scm +++ b/src/runtime/scomb.scm @@ -150,79 +150,34 @@ USA. ;;;; Combination (define (combination? object) - (or (object-type? (ucode-type combination) object) - (object-type? (ucode-type combination-1) object) - (object-type? (ucode-type combination-2) object) - (object-type? (ucode-type primitive-combination-0) object) - (object-type? (ucode-type primitive-combination-1) object) - (object-type? (ucode-type primitive-combination-2) object) - (object-type? (ucode-type primitive-combination-3) object))) + (object-type? (ucode-type combination) object)) (define-guarantee combination "SCode combination") (define (make-combination operator operands) (&typed-vector-cons (ucode-type combination) (cons operator operands))) - -(define-syntax combination-dispatch - (sc-macro-transformer - (lambda (form environment) - (let ((name (list-ref form 1)) - (combination (close-syntax (list-ref form 2) environment)) - (case-0 (close-syntax (list-ref form 3) environment)) - (case-1 (close-syntax (list-ref form 4) environment)) - (case-2 (close-syntax (list-ref form 5) environment)) - (case-n (close-syntax (list-ref form 6) environment))) - `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0) - ,combination) - ,case-0) - ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination) - (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1) - ,combination)) - ,case-1) - ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination) - (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2) - ,combination)) - ,case-2) - ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination) - (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3) - ,combination)) - ,case-n) - (ELSE - (ERROR:NOT-COMBINATION ,combination ',name))))))) (define (combination-size combination) - (combination-dispatch combination-size combination - 1 2 3 (&vector-length combination))) + (guarantee-combination combination 'COMBINATION-SIZE) + (&vector-length combination)) (define (combination-operator combination) - (combination-dispatch combination-operator combination - (object-new-type (ucode-type primitive) combination) - (&pair-car combination) - (&triple-first combination) - (&vector-ref combination 0))) + (guarantee-combination combination 'COMBINATION-OPERATOR) + (&vector-ref combination 0)) (define (combination-operands combination) - (combination-dispatch - combination-operands combination - '() - (list (&pair-cdr combination)) - (list (&triple-second combination) (&triple-third combination)) - (&subvector->list combination 1 (&vector-length combination)))) + (guarantee-combination combination 'COMBINATION-OPERANDS) + (&subvector->list combination 1 (&vector-length combination))) (define (combination-components combination receiver) - (combination-dispatch - combination-components combination - (receiver (object-new-type (ucode-type primitive) combination) '()) - (receiver (&pair-car combination) (list (&pair-cdr combination))) - (receiver (&triple-first combination) - (list (&triple-second combination) (&triple-third combination))) - (receiver (&vector-ref combination 0) - (&subvector->list combination 1 (&vector-length combination))))) + (guarantee-combination combination 'COMBINATION-OPERANDS) + (receiver (&vector-ref combination 0) + (&subvector->list combination 1 (&vector-length combination)))) (define (combination-subexpressions expression) (combination-components expression cons)) - + ;;;; Unassigned? (define (make-unassigned? name) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index bde57101a..502ad1f16 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -296,12 +296,6 @@ USA. (PRIMITIVE . PRIMITIVE-PROCEDURE) (LEXPR . LAMBDA) (EXTENDED-LAMBDA . LAMBDA) - (COMBINATION-1 . COMBINATION) - (COMBINATION-2 . COMBINATION) - (PRIMITIVE-COMBINATION-0 . COMBINATION) - (PRIMITIVE-COMBINATION-1 . COMBINATION) - (PRIMITIVE-COMBINATION-2 . COMBINATION) - (PRIMITIVE-COMBINATION-3 . COMBINATION) (SEQUENCE-2 . SEQUENCE))) (define (unparse/false object)