From b7c441833e7b84dd1705b2c5507ff603670d725b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 15 Sep 2007 19:57:28 +0000 Subject: [PATCH] tried to improve size of generated code for structs svn: r7348 --- collects/mzlib/private/contract-arrow.ss | 49 +++++++++++++++++++++--- collects/mzlib/private/contract.ss | 34 ++++++++-------- collects/tests/mzscheme/contract-test.ss | 6 +++ 3 files changed, 65 insertions(+), 24 deletions(-) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 3849097158..351bc4cb75 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -138,6 +138,30 @@ [else (apply build-compound-type-name 'values rngs)])]) (apply build-compound-type-name '-> (append doms/c (list rng-name))))])) + (define arity-one-wrapper + (lambda (chk a3 c5) (lambda (val) (chk val) (lambda (a1) (c5 (val (a3 a1))))))) + + (define arity-two-wrapper + (lambda (chk a3 b4 c5) (lambda (val) (chk val) (lambda (a1 b2) (c5 (val (a3 a1) (b4 b2))))))) + + (define arity-three-wrapper + (lambda (chk a9 b10 c11 r12) (lambda (val) (chk val) (lambda (a6 b7 c8) (r12 (val (a9 a6) (b10 b7) (c11 c8))))))) + + (define arity-four-wrapper + (lambda (chk a17 b18 c19 d20 r21) (lambda (val) (chk val) (lambda (a13 b14 c15 d16) (r21 (val (a17 a13) (b18 b14) (c19 c15) (d20 d16))))))) + + (define arity-five-wrapper + (lambda (chk a27 b28 c29 d30 e31 r32) + (lambda (val) (chk val) (lambda (a22 b23 c24 d25 e26) (r32 (val (a27 a22) (b28 b23) (c29 c24) (d30 d25) (e31 e26))))))) + + (define arity-six-wrapper + (lambda (chk a39 b40 c41 d42 e43 f44 r45) + (lambda (val) (chk val) (lambda (a33 b34 c35 d36 e37 f38) (r45 (val (a39 a33) (b40 b34) (c41 c35) (d42 d36) (e43 e37) (f44 f38))))))) + + (define arity-seven-wrapper + (lambda (chk a53 b54 c55 d56 e57 f58 g59 r60) + (lambda (val) (chk val) (lambda (a46 b47 c48 d49 e50 f51 g52) (r60 (val (a53 a46) (b54 b47) (c55 c48) (d56 d49) (e57 e50) (f58 f51) (g59 g52))))))) + (define-syntax-set (-> ->*) (define (->/proc stx) (let-values ([(stx _1 _2) (->/proc/main stx)]) @@ -157,11 +181,26 @@ (syntax (lambda args body)))] [use-any? use-any?]) (with-syntax ([outer-lambda - (syntax - (lambda (chk dom-names ... rng-names ...) - (lambda (val) - (chk val) - inner-lambda)))]) + (let* ([lst (syntax->list #'args)] + [len (and lst (length lst))]) + (if (and lst + (not (syntax-e #'use-any?)) + (= len (length (syntax->list #'(dom-names ...)))) + (= 1 (length (syntax->list #'(rng-names ...)))) + (<= 1 len 7)) + (case len + [(1) #'arity-one-wrapper] + [(2) #'arity-two-wrapper] + [(3) #'arity-three-wrapper] + [(4) #'arity-four-wrapper] + [(5) #'arity-five-wrapper] + [(6) #'arity-six-wrapper] + [(7) #'arity-seven-wrapper]) + (syntax + (lambda (chk dom-names ... rng-names ...) + (lambda (val) + (chk val) + inner-lambda)))))]) (values (syntax (build--> '-> (list dom-ctcs ...) diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index cd44e9b91c..12ea5176e7 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -529,14 +529,15 @@ improve method arity mismatch contract violation error messages? (syntax (begin (provide (rename id-rename struct-name)) (define-syntax id-rename - (list-immutable ((syntax-local-certifier) #'-struct:struct-name) - ((syntax-local-certifier) #'constructor-new-name) - ((syntax-local-certifier) #'predicate-new-name) - (list-immutable ((syntax-local-certifier) #'rev-selector-new-names) ... - ((syntax-local-certifier) #'rev-selector-old-names) ...) - (list-immutable ((syntax-local-certifier) #'rev-mutator-new-names) ... - ((syntax-local-certifier) #'rev-mutator-old-names) ...) - super-id)))))] + (let ([slc (syntax-local-certifier)]) + (list-immutable (slc #'-struct:struct-name) + (slc #'constructor-new-name) + (slc #'predicate-new-name) + (list-immutable (slc #'rev-selector-new-names) ... + (slc #'rev-selector-old-names) ...) + (list-immutable (slc #'rev-mutator-new-names) ... + (slc #'rev-mutator-old-names) ...) + super-id))))))] [struct:struct-name struct:struct-name] [-struct:struct-name -struct:struct-name] [struct-name struct-name] @@ -644,29 +645,24 @@ improve method arity mismatch contract violation error messages? (with-syntax ([(field-contract-ids ...) field-contract-ids] [predicate-id predicate-id]) (syntax/loc stx - (field-contract-ids - ... - . -> . - (let ([predicate-id (λ (x) (predicate-id x))]) predicate-id))))) + (-> field-contract-ids ... + predicate-id)))) ;; build-selector-contract : syntax syntax -> syntax ;; constructs the contract for a selector (define (build-selector-contract struct-name predicate-id field-contract-id) (with-syntax ([field-contract-id field-contract-id] [predicate-id predicate-id]) - (syntax ((let ([predicate-id (λ (x) (predicate-id x))]) predicate-id) - . -> . - field-contract-id)))) + (syntax (-> predicate-id field-contract-id)))) ;; build-mutator-contract : syntax syntax -> syntax ;; constructs the contract for a selector (define (build-mutator-contract struct-name predicate-id field-contract-id) (with-syntax ([field-contract-id field-contract-id] [predicate-id predicate-id]) - (syntax ((let ([predicate-id (λ (x) (predicate-id x))]) predicate-id) - field-contract-id - . -> . - void?)))) + (syntax (-> predicate-id + field-contract-id + void?)))) ;; code-for-one-id : syntax syntax syntax (union syntax #f) -> syntax ;; given the syntax for an identifier and a contract, diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index b1bf78ec81..f726d8b2a5 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -464,6 +464,12 @@ 'contract-arrow1 '(contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg)) + ;; make sure we skip the optimizations + (test/spec-passed + 'contract-arrow1b + '(contract (integer? integer? integer? integer? integer? integer? integer? integer? integer? integer? . -> . integer?) + (lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) x1) 'pos 'neg)) + (test/pos-blame 'contract-arrow2 '(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg))