From e37833b603360ca7c3329a80d5073770a275c632 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Sun, 2 Apr 2017 13:03:56 -0300 Subject: [PATCH 01/11] Add `signatures` field to primref record primref.ss, primvars.ss original commit: 0d044806bd5c645bf2c4caf701c2615d6150f8bf --- s/base-lang.ss | 4 ++-- s/primref.ss | 4 ++-- s/primvars.ss | 11 ++++++----- 3 files changed, 10 insertions(+), 9 deletions(-) diff --git a/s/base-lang.ss b/s/base-lang.ss index 8a18331ca6..3787eb6279 100644 --- a/s/base-lang.ss +++ b/s/base-lang.ss @@ -14,14 +14,14 @@ ;;; limitations under the License. (module (Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc count-Lsrc - lookup-primref primref? primref-name primref-level primref-flags primref-arity + lookup-primref primref? primref-name primref-level primref-flags primref-arity primref-signatures sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags preinfo-lambda-libspec prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set! prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex* target-fixnum? target-bignum?) - (module (lookup-primref primref? primref-name primref-flags primref-arity primref-level) + (module (lookup-primref primref? primref-name primref-flags primref-arity primref-signatures primref-level) (include "primref.ss") (define $lookup-primref diff --git a/s/primref.ss b/s/primref.ss index 6f734bb8e8..16438fc667 100644 --- a/s/primref.ss +++ b/s/primref.ss @@ -14,9 +14,9 @@ ;;; limitations under the License. (define-record-type primref - (nongenerative #{primref a0xltlrcpeygsahopkplcn-2}) + (nongenerative #{primref a0xltlrcpeygsahopkplcn-3}) (sealed #t) - (fields name flags arity)) + (fields name flags arity signatures)) (define primref-level (lambda (pr) diff --git a/s/primvars.ss b/s/primvars.ss index 3a5b6748aa..a1bb600173 100644 --- a/s/primvars.ss +++ b/s/primvars.ss @@ -18,19 +18,19 @@ (include "primref.ss") (define record-prim! - (lambda (prim unprefixed flags arity boolean-valued?) + (lambda (prim unprefixed flags arity boolean-valued? signatures) (unless (eq? unprefixed prim) ($sputprop prim '*unprefixed* unprefixed)) (let ([flags (if boolean-valued? (fxlogor flags (prim-mask boolean-valued)) flags)] [arity (and (not (null? arity)) arity)]) ($sputprop prim '*flags* flags) (when (any-set? (prim-mask (or primitive system)) flags) - ($sputprop prim '*prim2* (make-primref prim flags arity)) - ($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity)))))) + ($sputprop prim '*prim2* (make-primref prim flags arity signatures)) + ($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity signatures)))))) (define-syntax setup (lambda (x) (import priminfo) - ; sort vector of primitive names so boot files compare equal + ; sort vector of primitive names so boot files compare equal (let ([v-prim (vector-sort (lambda (x y) (string<=? (symbol->string x) (symbol->string y))) (primvec))]) (let ([v-info (vector-map get-priminfo v-prim)]) #`(vector-for-each record-prim! @@ -38,7 +38,8 @@ '#,(datum->syntax #'* (vector-map priminfo-unprefixed v-info)) '#,(datum->syntax #'* (vector-map priminfo-mask v-info)) '#,(datum->syntax #'* (vector-map priminfo-arity v-info)) - '#,(datum->syntax #'* (vector-map priminfo-boolean? v-info))))))) + '#,(datum->syntax #'* (vector-map priminfo-boolean? v-info)) + '#,(datum->syntax #'* (vector-map priminfo-signatures v-info))))))) (for-each (lambda (x) (for-each (lambda (key) ($sremprop x key)) '(*prim2* *prim3* *flags* *unprefixed*))) (oblist)) setup) From 168065175d4bc22fda0062ff093362497fdcc306 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Sun, 13 Aug 2017 18:54:08 -0400 Subject: [PATCH 02/11] Hashing of prelex for cptypes original commit: c3d5c784cdf1ffe73abc35f824e588509d98df38 --- s/base-lang.ss | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/s/base-lang.ss b/s/base-lang.ss index 3787eb6279..9f1d829966 100644 --- a/s/base-lang.ss +++ b/s/base-lang.ss @@ -18,7 +18,7 @@ sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags preinfo-lambda-libspec prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set! - prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex* + prelex-source prelex-operand prelex-operand-set! prelex-uname prelex-counter make-prelex* target-fixnum? target-bignum?) (module (lookup-primref primref? primref-name primref-flags primref-arity primref-signatures primref-level) @@ -78,15 +78,16 @@ prelex-flags prelex-flags-set! prelex-source prelex-operand prelex-operand-set! - prelex-uname) + prelex-uname + prelex-counter) (define-record-type prelex - (nongenerative #{prelex grpmhtzqa9bflxfggfu6pp-0}) + (nongenerative #{prelex grpmhtzqa9bflxfggfu6pp-1}) (sealed #t) - (fields (mutable name) (mutable flags) source (mutable operand) (mutable $uname)) + (fields (mutable name) (mutable flags) source (mutable operand) (mutable $uname) (mutable $counter)) (protocol (lambda (new) (lambda (name flags source operand) - (new name flags source operand #f))))) + (new name flags source operand #f #f))))) (define prelex-uname (lambda (id) (or (prelex-$uname id) @@ -94,6 +95,16 @@ (with-tc-mutex (or (prelex-$uname id) (begin (prelex-$uname-set! id uname) uname))))))) + (define counter 0) + (define prelex-counter + (lambda (id) + (or (prelex-$counter id) + (with-tc-mutex + (or (prelex-$counter id) + (let ([c counter]) + (set! counter (fx1+ counter)) + (prelex-$counter-set! id c) + c)))))) (record-writer (record-type-descriptor prelex) (lambda (x p wr) (fprintf p "~s" (prelex-name x))))) From 1a5f731752f7cb524330fb40d1da27efc8b2a344 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Sat, 19 Aug 2017 22:48:51 -0300 Subject: [PATCH 03/11] Add fxmap for cptypes original commit: 6c6ff6f6ef513ed586bab4b6bc6bfa4676daed98 --- s/Mf-base | 6 +- s/fxmap.ss | 247 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 250 insertions(+), 3 deletions(-) create mode 100644 s/fxmap.ss diff --git a/s/Mf-base b/s/Mf-base index 35fce73394..8b0fd8ec97 100644 --- a/s/Mf-base +++ b/s/Mf-base @@ -149,7 +149,7 @@ macroobj =\ allsrc =\ ${basesrc} ${compilersrc} cmacros.ss ${archincludes} setup.ss debug.ss priminfo.ss primdata.ss layout.ss\ base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss\ - np-languages.ss + np-languages.ss fxmap.ss # doit uses a different Scheme process to compile each target doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} @@ -393,7 +393,7 @@ endif script.all: Mf-base -script.all makescript: +script.all makescript: echo '(reset-handler abort)'\ '(for-each load (command-line-arguments))'\ '(optimize-level $o)'\ @@ -491,7 +491,7 @@ primvars.so setup.so mkheader.so env.so: cmacros.so priminfo.so primref.ss setup.so: debug.ss ${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss env.ss -cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss ${archincludes} +cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss fxmap.ss ${archincludes} 5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss ${Cheader}: mkheader.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss diff --git a/s/fxmap.ss b/s/fxmap.ss new file mode 100644 index 0000000000..342760243d --- /dev/null +++ b/s/fxmap.ss @@ -0,0 +1,247 @@ +;; Based on Okasaki and Gill's "Fast Mergeable Integer Maps" (1998). + +(module fxmap + (fxmap? + empty-fxmap + fxmap-empty? + fxmap-count + fxmap-ref + fxmap-set + fxmap-remove + fxmap-merge + + ;; internals + $branch? make-$branch $branch-prefix $branch-mask $branch-left $branch-right + $leaf? make-$leaf $leaf-key $leaf-val + $empty?) + + ;; record types + + (define-record-type $branch + [fields prefix mask left right] + [nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-0}] + [sealed #t]) + + (define-record-type $leaf + [fields key val] + [nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-0}] + [sealed #t]) + + (define-record-type $empty + [nongenerative #{$empty pfwk1nal7cs5dornqtzvda91m-0}] + [sealed #t]) + + ;; constants + + (define empty-fxmap (make-$empty)) + + ;; predicate + + (define (fxmap? x) + (or ($branch? x) + ($leaf? x) + ($empty? x))) + + ;; count & empty + + (define (fxmap-count d) + (let loop ([d d] [n 0]) + (cond [($branch? d) + (let ([nl (loop ($branch-left d) n)]) + (loop ($branch-right d) nl))] + [($leaf? d) (fx1+ n)] + [else n]))) + + (define fxmap-empty? $empty?) + + ;; ref + + (define (fxmap-ref d key default) + (cond [($branch? d) + (if (fx<= key ($branch-prefix d)) + (fxmap-ref ($branch-left d) key default) + (fxmap-ref ($branch-right d) key default))] + + [($leaf? d) + (if (fx= key ($leaf-key d)) + ($leaf-val d) + default)] + + [else + default])) + + ;; set + + (define (fxmap-set d key val) + (cond + [($branch? d) + (let ([p ($branch-prefix d)] + [m ($branch-mask d)]) + (cond + [(nomatch? key p m) + (join key (make-$leaf key val) p d)] + [(fx<= key p) + (br p m (fxmap-set ($branch-left d) key val) ($branch-right d))] + [else + (br p m ($branch-left d) (fxmap-set ($branch-right d) key val))]))] + + [($leaf? d) + (let ([k ($leaf-key d)]) + (if (fx= key k) + (make-$leaf key val) + (join key (make-$leaf key val) k d)))] + + [else + (make-$leaf key val)])) + + ;; remove + + (define (fxmap-remove d key) + (cond + [($branch? d) + (let ([p ($branch-prefix d)] + [m ($branch-mask d)]) + (cond + [(nomatch? key p m) d] + [(fx<= key p) (br* p m (fxmap-remove ($branch-left d) key) ($branch-right d))] + [else (br* p m ($branch-left d) (fxmap-remove ($branch-right d) key))]))] + + [($leaf? d) + (if (fx= key ($leaf-key d)) + empty-fxmap + d)] + + [else + empty-fxmap])) + + ;; set and remove utilities + + (define-syntax define-syntax-rule + (syntax-rules () + [(_ (name arg ...) e ...) + (define-syntax name + (syntax-rules () + [(_ arg ...) e ...]))])) + + (define br make-$branch) + + (define (br* p m l r) + (cond [($empty? r) l] + [($empty? l) r] + [else (br p m l r)])) + + (define (join p0 d0 p1 d1) + (let ([m (branching-bit p0 p1)]) + (if (fx<= p0 p1) + (br (mask p0 m) m d0 d1) + (br (mask p0 m) m d1 d0)))) + + (define (join* p1 d1 p2 d2) + (cond + [($empty? d1) d2] + [($empty? d2) d1] + [else (join p1 d1 p2 d2)])) + + (define (branching-bit p m) + (highest-set-bit (fxxor p m))) + + (define-syntax-rule (mask h m) + (fxand (fxior h (fx1- m)) (fxnot m))) + + (define (highest-set-bit x1) + (let* ([x2 (fxior x1 (fxsrl x1 1))] + [x3 (fxior x2 (fxsrl x2 2))] + [x4 (fxior x3 (fxsrl x3 4))] + [x5 (fxior x4 (fxsrl x4 8))] + [x6 (fxior x5 (fxsrl x5 16))] + [x7 (fxior x6 (fxsrl x6 32))]) + (fxxor x7 (fxsrl x7 1)))) + + (define-syntax-rule (nomatch? h p m) + (not (fx= (mask h m) p))) + + ;; merge + + (define (fxmap-merge bin f id g1 g2 d1 d2) + (define-syntax go + (syntax-rules () + [(_ d1 d2) (fxmap-merge bin f id g1 g2 d1 d2)])) + + (cond + [(eq? d1 d2) (id d1)] + + [($branch? d1) + (cond + [($branch? d2) + (let-branch + ([(p1 m1 l1 r1) d1] [(p2 m2 l2 r2) d2]) + (cond + [(fx> m1 m2) (cond + [(nomatch? p2 p1 m1) (join* p1 (g1 d1) p2 (g2 d2))] + [(fx<= p2 p1) (bin p1 m1 (go l1 d2) (g1 r1))] + [else (bin p1 m1 (g1 l1) (go r1 d2))])] + [(fx> m2 m1) (cond + [(nomatch? p1 p2 m2) (join* p1 (g1 d1) p2 (g2 d2))] + [(fx<= p1 p2) (bin p2 m2 (go d1 l2) (g2 r2))] + [else (bin p2 m2 (g2 l2) (go d1 r2))])] + [(fx= p1 p2) (bin p1 m1 (go l1 l2) (go r1 r2))] + [else (join* p1 (g1 d1) p2 (g2 d2))]))] + + [($leaf? d2) + (let ([k2 ($leaf-key d2)]) + (let merge0 ([d1 d1]) + (cond + [(eq? d1 d2) + (id d1)] + + [($branch? d1) + (let-branch + ([(p1 m1 l1 r1) d1]) + (cond [(nomatch? k2 p1 m1) (join* p1 (g1 d1) k2 (g2 d2))] + [(fx<= k2 p1) (bin p1 m1 (merge0 l1) (g1 r1))] + [else (bin p1 m1 (g1 l1) (merge0 r1))]))] + + [($leaf? d1) + (let ([k1 ($leaf-key d1)]) + (cond [(fx= k1 k2) (f d1 d2)] + [else (join* k1 (g1 d1) k2 (g2 d2))]))] + + [else ; ($empty? d1) + (g2 d2)])))] + + [else ;; ($empty? d2) + (g1 d1)])] + + [($leaf? d1) + (let ([k1 ($leaf-key d1)]) + (let merge0 ([d2 d2]) + (cond + [(eq? d1 d2) + (id d1)] + + [($branch? d2) + (let-branch + ([(p2 m2 l2 r2) d2]) + (cond [(nomatch? k1 p2 m2) (join* k1 (g1 d1) p2 (g2 d2))] + [(fx<= k1 p2) (bin p2 m2 (merge0 l2) (g2 r2))] + [else (bin p2 m2 (g2 l2) (merge0 r2))]))] + + [($leaf? d2) + (let ([k2 ($leaf-key d2)]) + (cond [(fx= k1 k2) (f d1 d2)] + [else (join* k1 (g1 d1) k2 (g2 d2))]))] + + [else ; ($empty? d2) + (g1 d1)])))] + + [else ; ($empty? d1) + (g2 d2)])) + + (define-syntax let-branch + (syntax-rules () + [(_ ([(p m l r) d] ...) exp ...) + (let ([p ($branch-prefix d)] ... + [m ($branch-mask d)] ... + [l ($branch-left d)] ... + [r ($branch-right d)] ...) + exp ...)]))) From b2f9a3e11fca31985c2c018407d4a3c614b7fe20 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Sat, 7 Oct 2017 20:07:05 -0300 Subject: [PATCH 04/11] Add more operations to fxmap original commit: 304cc0adc4dc881dea4d17695b73bf345da07dca --- s/fxmap.ss | 248 +++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 201 insertions(+), 47 deletions(-) diff --git a/s/fxmap.ss b/s/fxmap.ss index 342760243d..379aaceb69 100644 --- a/s/fxmap.ss +++ b/s/fxmap.ss @@ -1,3 +1,18 @@ +;;; fxmap.ss +;;; Copyright 1984-2017 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + ;; Based on Okasaki and Gill's "Fast Mergeable Integer Maps" (1998). (module fxmap @@ -8,23 +23,29 @@ fxmap-ref fxmap-set fxmap-remove - fxmap-merge + fxmap-remove/base + fxmap-reset/base + fxmap-advance/base + fxmap-for-each + fxmap-for-each/diff + fxmap-changes ;; internals - $branch? make-$branch $branch-prefix $branch-mask $branch-left $branch-right - $leaf? make-$leaf $leaf-key $leaf-val - $empty?) + ; $branch? make-$branch $branch-prefix $branch-mask $branch-left $branch-right + ; $leaf? make-$leaf $leaf-key $leaf-val + ; $empty? make-$empty + ) ;; record types (define-record-type $branch - [fields prefix mask left right] - [nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-0}] + [fields prefix mask left right count changes] + [nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-1}] [sealed #t]) (define-record-type $leaf - [fields key val] - [nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-0}] + [fields key val changes] + [nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-1}] [sealed #t]) (define-record-type $empty @@ -42,69 +63,93 @@ ($leaf? x) ($empty? x))) - ;; count & empty + ;; count, changes & empty (define (fxmap-count d) - (let loop ([d d] [n 0]) - (cond [($branch? d) - (let ([nl (loop ($branch-left d) n)]) - (loop ($branch-right d) nl))] - [($leaf? d) (fx1+ n)] - [else n]))) + (cond + [($branch? d) + ($branch-count d)] + [($leaf? d) 1] + [else 0])) + + (define (fxmap-changes d) + (cond + [($branch? d) + ($branch-changes d)] + [($leaf? d) + ($leaf-changes d)] + [else 0])) (define fxmap-empty? $empty?) ;; ref + (define (fxmap-ref/leaf d key) + (cond + [($branch? d) + (let-branch ([(p m l r) d]) + (cond + [(fx<= key p) + (fxmap-ref/leaf l key)] + [else + (fxmap-ref/leaf r key)]))] + + [($leaf? d) + (if (fx= key ($leaf-key d)) + d + #f)] + + [else + #f])) + (define (fxmap-ref d key default) - (cond [($branch? d) - (if (fx<= key ($branch-prefix d)) - (fxmap-ref ($branch-left d) key default) - (fxmap-ref ($branch-right d) key default))] + (let ([d (fxmap-ref/leaf d key)]) + (if d + ($leaf-val d) + default))) - [($leaf? d) - (if (fx= key ($leaf-key d)) - ($leaf-val d) - default)] - - [else - default])) + (define (fxmap-ref/changes d key) + (let ([d (fxmap-ref/leaf d key)]) + (if d + ($leaf-changes d) + 0))) ;; set - (define (fxmap-set d key val) + (define (fxmap-set/changes d key val changes) (cond [($branch? d) - (let ([p ($branch-prefix d)] - [m ($branch-mask d)]) + (let-branch ([(p m l r) d]) (cond [(nomatch? key p m) - (join key (make-$leaf key val) p d)] + (join key (make-$leaf key val (or changes 1)) p d)] [(fx<= key p) - (br p m (fxmap-set ($branch-left d) key val) ($branch-right d))] + (br p m (fxmap-set/changes l key val changes) r)] [else - (br p m ($branch-left d) (fxmap-set ($branch-right d) key val))]))] + (br p m l (fxmap-set/changes r key val changes))]))] [($leaf? d) (let ([k ($leaf-key d)]) (if (fx= key k) - (make-$leaf key val) - (join key (make-$leaf key val) k d)))] + (make-$leaf key val (or changes (fx+ ($leaf-changes d) 1))) + (join key (make-$leaf key val (or changes 1)) k d)))] [else - (make-$leaf key val)])) + (make-$leaf key val (or changes 1))])) + + (define (fxmap-set d key val) + (fxmap-set/changes d key val #f)) ;; remove (define (fxmap-remove d key) (cond [($branch? d) - (let ([p ($branch-prefix d)] - [m ($branch-mask d)]) + (let-branch ([(p m l r) d]) (cond [(nomatch? key p m) d] - [(fx<= key p) (br* p m (fxmap-remove ($branch-left d) key) ($branch-right d))] - [else (br* p m ($branch-left d) (fxmap-remove ($branch-right d) key))]))] + [(fx<= key p) (br* p m (fxmap-remove l key) r)] + [else (br* p m l (fxmap-remove r key))]))] [($leaf? d) (if (fx= key ($leaf-key d)) @@ -114,6 +159,83 @@ [else empty-fxmap])) + (define (fxmap-remove/base d key base) + ; Remove key from d, but try to reuse the branches from base when possible + ; instead of creating new ones. + ; TODO: This assumes that all the keys in base are in d too. + ; Perhaps this restriction can be removed. + (cond + [($branch? base) + (cond + [($branch? d) + (let-branch ([(p0 m0 l0 r0) base] + [(p m l r) d]) + (let ([sub-base (cond + [(fx< m0 m) base] + [(fx<= key p0) l0] + [else r0])]) + (cond + [(nomatch? key p m) + d] + [(fx<= key p) + (br*/base p m (fxmap-remove/base l key sub-base) r base)] + [else + (br*/base p m l (fxmap-remove/base r key sub-base) base)])))] + + [($leaf? d) + (if (fx= key ($leaf-key d)) + empty-fxmap + d)] + + [else + empty-fxmap])] + [else + (fxmap-remove d key)])) + + ;; reset and advance + + (define (fxmap-reset/base d key base) + ; Reset key in d to the value it has in base, but try to reuse the branches + ; from base when possible instead of creating new ones. + ; TODO: This assumes that all the keys in base are in d too. + ; Perhaps this restriction can be removed. + (cond + [($branch? d) + (let-branch ([(p m l r) d]) + (let ([sub-base (cond + [($branch? base) + (let-branch ([(p0 m0 l0 r0) base]) + (cond + [(fx< m0 m) base] + [(fx<= key p0) l0] + [else r0]))] + [else base])]) + (cond + [(nomatch? key p m) + d] + [(fx<= key p) + (br*/base p m (fxmap-reset/base l key sub-base) r base)] + [else + (br*/base p m l (fxmap-reset/base r key sub-base) base)])))] + + [(and ($leaf? d) + (fx= key ($leaf-key d)) + ($leaf? base) + (fx= key ($leaf-key base))) + base] + + [else + (error 'fxmap-reset/base "")])) + + (define (fxmap-advance/base d key base) + (let ([changes (fx+ (fxmap-ref/changes base key) 1)] + [l (fxmap-ref/leaf d key)]) + (if l + (if (fx= changes ($leaf-changes l)) + d + (fxmap-set/changes d key ($leaf-val l) changes)) + (error 'fxmap-advance/base "")))) + ;; set and remove utilities (define-syntax define-syntax-rule @@ -123,13 +245,25 @@ (syntax-rules () [(_ arg ...) e ...]))])) - (define br make-$branch) + (define (br p m l r) + (make-$branch p m l r + (fx+ (fxmap-count l) (fxmap-count r)) + (fx+ (fxmap-changes l) (fxmap-changes r)))) (define (br* p m l r) (cond [($empty? r) l] [($empty? l) r] [else (br p m l r)])) + (define (br*/base p m l r base) + (cond [($empty? r) l] + [($empty? l) r] + [(and ($branch? base) + (eq? l ($branch-left base)) + (eq? r ($branch-right base))) + base] + [else (br p m l r)])) + (define (join p0 d0 p1 d1) (let ([m (branching-bit p0 p1)]) (if (fx<= p0 p1) @@ -173,8 +307,8 @@ [($branch? d1) (cond [($branch? d2) - (let-branch - ([(p1 m1 l1 r1) d1] [(p2 m2 l2 r2) d2]) + (let-branch ([(p1 m1 l1 r1) d1] + [(p2 m2 l2 r2) d2]) (cond [(fx> m1 m2) (cond [(nomatch? p2 p1 m1) (join* p1 (g1 d1) p2 (g2 d2))] @@ -195,8 +329,7 @@ (id d1)] [($branch? d1) - (let-branch - ([(p1 m1 l1 r1) d1]) + (let-branch ([(p1 m1 l1 r1) d1]) (cond [(nomatch? k2 p1 m1) (join* p1 (g1 d1) k2 (g2 d2))] [(fx<= k2 p1) (bin p1 m1 (merge0 l1) (g1 r1))] [else (bin p1 m1 (g1 l1) (merge0 r1))]))] @@ -220,8 +353,7 @@ (id d1)] [($branch? d2) - (let-branch - ([(p2 m2 l2 r2) d2]) + (let-branch ([(p2 m2 l2 r2) d2]) (cond [(nomatch? k1 p2 m2) (join* k1 (g1 d1) p2 (g2 d2))] [(fx<= k1 p2) (bin p2 m2 (merge0 l2) (g2 r2))] [else (bin p2 m2 (g2 l2) (merge0 r2))]))] @@ -244,4 +376,26 @@ [m ($branch-mask d)] ... [l ($branch-left d)] ... [r ($branch-right d)] ...) - exp ...)]))) + exp ...)])) + + (define (fxmap-for-each g1 d1) + (cond + [($branch? d1) + (fxmap-for-each g1 ($branch-left d1)) + (fxmap-for-each g1 ($branch-right d1))] + [($leaf? d1) + (g1 ($leaf-key d1) ($leaf-val d1))] + [else ; ($empty? d1) + (void)]) + (void)) + + (define (fxmap-for-each/diff f g1 g2 d1 d2) + (fxmap-merge (lambda (prefix mask left right) (make-$empty)) + (lambda (x y) (f ($leaf-key x) ($leaf-val x) ($leaf-val y)) (make-$empty)) + (lambda (x) (make-$empty)) + (lambda (x) (fxmap-for-each g1 x) (make-$empty)) + (lambda (x) (fxmap-for-each g2 x) (make-$empty)) + d1 + d2) + (void)) +) From 6e5ddb69685abf3073ea221581255879098456e7 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Sat, 27 May 2017 19:33:13 -0300 Subject: [PATCH 05/11] Add cptypes pass to cp0 to reduce expression using types - cptypes.ss, ... Thanks to Jon Zeppieri. original commit: af0a075e479e8831c9961102e97db9f00f141fa8 --- mats/Mf-base | 2 +- mats/cptypes.ms | 518 ++++++++++++++++++++++++ mats/record.ms | 18 +- s/Mf-base | 4 +- s/compile.ss | 5 +- s/cprep.ss | 2 +- s/cptypes.ss | 1029 +++++++++++++++++++++++++++++++++++++++++++++++ s/front.ss | 1 + s/interpret.ss | 2 +- s/primdata.ss | 1 + 10 files changed, 1563 insertions(+), 19 deletions(-) create mode 100644 mats/cptypes.ms create mode 100644 s/cptypes.ss diff --git a/mats/Mf-base b/mats/Mf-base index db0fd1aed7..f19e650bdc 100644 --- a/mats/Mf-base +++ b/mats/Mf-base @@ -125,7 +125,7 @@ ecpf = $(defaultecpf) # set of mats to run mats = primvars 3 4 5_1 5_2 5_3 5_4 5_5 bytevector thread\ - misc cp0 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\ + misc cp0 cptypes 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\ ftype unix windows examples ieee date exceptions oop Examples = ../examples diff --git a/mats/cptypes.ms b/mats/cptypes.ms new file mode 100644 index 0000000000..8562b48e94 --- /dev/null +++ b/mats/cptypes.ms @@ -0,0 +1,518 @@ +;;; cptypes.ms +;;; Copyright 1984-2017 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define-syntax cptypes-equivalent-expansion? + (syntax-rules () + [(_ x y) + (equivalent-expansion? + (parameterize ([enable-cp0 #t] + [#%$suppress-primitive-inlining #f] + #;[optimize-level (max (optimize-level) 2)]) + (expand/optimize x)) + (parameterize ([enable-cp0 #t] + [#%$suppress-primitive-inlining #f] + #;[optimize-level (max (optimize-level) 2)]) + (expand/optimize y)))])) + +(mat cptypes-handcoded + (cptypes-equivalent-expansion? + '(vector? (vector)) ;actually reduced by folding, not cptypes + #t) + (cptypes-equivalent-expansion? + '(vector? (vector 1 2 3)) + #t) + (cptypes-equivalent-expansion? + '(vector? (box 1)) + #f) + (cptypes-equivalent-expansion? + '(box? (vector 1 2 3)) + #f) + (cptypes-equivalent-expansion? + '(box? (box 1)) + #t) + (cptypes-equivalent-expansion? + '(pair? (cons 1 2)) + #t) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x 0 0) (vector? x)) + '(lambda (x) (vector-set! x 0 0) #t)) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x 0 0) (box? x)) + '(lambda (x) (vector-set! x 0 0) #f)) + (cptypes-equivalent-expansion? + '(lambda (x y) (vector-set! x 0 0) (set! y (vector? x))) + '(lambda (x y) (vector-set! x 0 0) (set! y #t))) + (cptypes-equivalent-expansion? + '(lambda (x y) (set! y (vector-ref x 0)) (list (vector? x) y)) + '(lambda (x y) (set! y (vector-ref x 0)) (list #t y))) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x 0 0) (let ([y (random 7)]) (list (vector? x) y y))) + '(lambda (x) (vector-set! x 0 0) (let ([y (random 7)]) (list #t y y)))) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x 0 0) (let ([y (vector? x)]) (list (random 7) y y))) + '(lambda (x) (vector-set! x 0 0) (let ([y #t]) (list (random 7) y y)))) + (cptypes-equivalent-expansion? + '(lambda (x) (let ([y (vector-ref x 0)]) (list (vector? x) y y))) + '(lambda (x) (let ([y (vector-ref x 0)]) (list #t y y)))) + (cptypes-equivalent-expansion? + '(lambda (x) (let ([y (vector-ref x 0)]) + (let ([z (vector? x)]) + (list y y z z)))) + '(lambda (x) (let ([y (vector-ref x 0)]) + (let ([z #t]) + (list y y z z))))) + (cptypes-equivalent-expansion? + '(lambda (x) (let ([y (vector-ref x 0)]) (display (list y y))) (vector? x)) + '(lambda (x) (let ([y (vector-ref x 0)]) (display (list y y))) #t)) + (cptypes-equivalent-expansion? + '(lambda (x) (let ([y (random 7)]) (display (list (vector-ref x 0) y y))) (vector? x)) + '(lambda (x) (let ([y (random 7)]) (display (list (vector-ref x 0) y y))) #t)) + (cptypes-equivalent-expansion? + '(let ([y (vector 1 2 3)]) (display (list (vector? y) y y))) + '(let ([y (vector 1 2 3)]) (display (list #t y y)))) + (cptypes-equivalent-expansion? + '(let ([y (vector 1 2 3)]) (display (list y y)) (vector? y)) + '(let ([y (vector 1 2 3)]) (display (list y y)) #t)) + (cptypes-equivalent-expansion? + '(vector? (let ([y (vector 1 2 3)]) (display (list y y)) y)) + '(begin (let ([y (vector 1 2 3)]) (display (list y y)) y) #t)) + (cptypes-equivalent-expansion? + '(vector? (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6))) + '(begin (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6)) #t)) + (cptypes-equivalent-expansion? + '(lambda (x) (when (null? x) (display x))) + '(lambda (x) (when (null? x) (display '())))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (vector? x) (eq? x 'vector?))) + '(lambda (x) (when (vector? x) #f))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (vector? x) (pair? x))) + '(lambda (x) (when (vector? x) #f))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (vector? x) (vector? x))) + '(lambda (x) (when (vector? x) #t))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (procedure? x) (procedure? x))) + '(lambda (x) (when (procedure? x) #t))) + (cptypes-equivalent-expansion? + '(lambda (f) (f) (procedure? f)) + '(lambda (f) (f) #t)) + (cptypes-equivalent-expansion? + '(lambda (x) + (vector-set! x 0 0) + (let loop ([n 1000]) + (unless (zero? n) + (display (vector? x)) + (loop (- n 1))))) + '(lambda (x) + (vector-set! x 0 0) + (let loop ([n 1000]) + (unless (zero? n) + (display #t) + (loop (- n 1)))))) + (cptypes-equivalent-expansion? + '(lambda (x) + (let loop ([n 1000]) + (unless (zero? n) + (vector-set! x 0 n) + (loop (- n 1)))) + (vector? x)) + '(lambda (x) + (let loop ([n 1000]) + (unless (zero? n) + (vector-set! x 0 n) + (loop (- n 1)))) + (vector? x))) + (cptypes-equivalent-expansion? + '(begin (error 'who "msg") 1) ;could be reduced in cp0 + '(begin (error 'who "msg") 2)) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x) 1) + '(lambda (x) (vector-set! x) 2)) + (cptypes-equivalent-expansion? + '(lambda (x) (#2%-) 1) + '(lambda (x) (#2%-) 2)) + (cptypes-equivalent-expansion? + '(lambda (x) (#2%make-vector x 0 7) 1) + '(lambda (x) (#2%make-vector x 0 7) 2)) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x 0 0) (set-box! x 0) 1) + '(lambda (x) (vector-set! x 0 0) (set-box! x 0) 2)) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! (box 5) 0 0) 1) + '(lambda (x) (vector-set! (box 5) 0 0) 2)) + (cptypes-equivalent-expansion? + '(lambda (x) (#2%odd? x) (real? x)) + '(lambda (x) (#2%odd? x) #t)) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x 0 0) (#2%odd? x) 1) + '(lambda (x) (vector-set! x 0 0) (#2%odd? x) 2)) +) + +(mat cptypes-type-if + (cptypes-equivalent-expansion? + '(lambda (x) (if (vector-ref x 0) (newline) (void)) (vector? x)) + '(lambda (x) (if (vector-ref x 0) (newline) (void)) #t)) + (cptypes-equivalent-expansion? + '(lambda (x) (if (vector-ref x 0) (vector? x) (void))) + '(lambda (x) (if (vector-ref x 0) #t (void)))) + (cptypes-equivalent-expansion? + '(lambda (x) (if (vector-ref x 0) (void) (vector? x))) + '(lambda (x) (if (vector-ref x 0) (void) #t))) + (cptypes-equivalent-expansion? + '(lambda (x) (if (zero? (vector-ref x 0)) (newline) (void)) (vector? x)) + '(lambda (x) (if (zero? (vector-ref x 0)) (newline) (void)) #t)) + (not (cptypes-equivalent-expansion? + '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (void)) (vector? x)) + '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (void)) #t))) + (not (cptypes-equivalent-expansion? + '(lambda (x) (if (zero? (random 2)) (void) (vector-set! x 0 0)) (vector? x)) + '(lambda (x) (if (zero? (random 2)) (void) (vector-set! x 0 0)) #t))) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x 0 0) (if x (newline) (void))) + '(lambda (x) (vector-set! x 0 0) (if #t (newline) (void)))) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x 0 0) (if (vector? x) (newline) (void))) + '(lambda (x) (vector-set! x 0 0) (if #t (newline) (void)))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (vector? x) (if x (newline) (void)))) + '(lambda (x) (when (vector? x) (if #t (newline) (void))))) + (not (cptypes-equivalent-expansion? + '(lambda (x) (when (boolean? x) (if x (newline) (void)))) + '(lambda (x) (when (boolean? x) (if #t (newline) (void)))))) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (vector? x) (void))) + '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) #t (void)))) + (cptypes-equivalent-expansion? + '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (void) (vector? x))) + '(lambda (x) (vector-set! x 0 0) (if (zero? (random 2)) (void) #t))) + (cptypes-equivalent-expansion? + '(lambda (x) (if (vector? x) (vector? x) (void))) + '(lambda (x) (if (vector? x) #t (void)))) + (not (cptypes-equivalent-expansion? + '(lambda (x) (if (vector? x) (void) (vector? x))) + '(lambda (x) (if (vector? x) (void) #t)))) + (cptypes-equivalent-expansion? + '(lambda (x y) (if (vector? x) (if (vector? y) (list (vector? x) (vector? y)) (void)) (void))) + '(lambda (x y) (if (vector? x) (if (vector? y) (list #t #t) (void)) (void)))) + (cptypes-equivalent-expansion? + '(lambda (x y) (if (and (vector? x) (vector? y)) (list (vector? x) (vector? y)) (void))) + '(lambda (x y) (if (and (vector? x) (vector? y)) (list #t #t) (void)))) + (not (cptypes-equivalent-expansion? + '(lambda (x y) (if (or (vector? x) (vector? y)) (vector? x) (void))) + '(lambda (x y) (if (or (vector? x) (vector? y)) #t (void))))) + (not (cptypes-equivalent-expansion? + '(lambda (x y) (if (or (vector? x) (vector? y)) (vector? y) (void))) + '(lambda (x y) (if (or (vector? x) (vector? y)) #t (void))))) + (cptypes-equivalent-expansion? + '(lambda (x y) (if (if (vector? x) (vector? y) #f) (list (vector? x) (vector? y)) (void))) + '(lambda (x y) (if (if (vector? x) (vector? y) #f) (list #t #t) (void)))) + (cptypes-equivalent-expansion? + '(lambda (x y) (if (if (vector? x) (vector? y) #t) (void) (vector? x))) + '(lambda (x y) (if (if (vector? x) (vector? y) #t) (void) #t))) + (cptypes-equivalent-expansion? + '(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) (number? x))) + '(lambda (t) (let ([x (if t (begin (newline) #f) #f)]) #f))) + (cptypes-equivalent-expansion? + '(lambda (t) (let ([x (if t 1 2)]) (fixnum? x))) + '(lambda (t) (let ([x (if t 1 2)]) #t))) + (cptypes-equivalent-expansion? + '(lambda (t) (let ([x (if t 1 2.0)]) (number? x))) + '(lambda (t) (let ([x (if t 1 2.0)]) #t))) + (cptypes-equivalent-expansion? + '(if (error 'who "msg") (display 1) (display 2)) + '(if (error 'who "msg") (display -1) (display -2))) + (cptypes-equivalent-expansion? + '(begin (if (error 'who "msg") (display 1) (display 2)) (display 3)) + '(begin (if (error 'who "msg") (display 1) (display 2)) (display -3))) + (cptypes-equivalent-expansion? + '(begin (if (box? (box 0)) (error 'who "msg") (void)) (display 1)) + '(begin (if (box? (box 0)) (error 'who "msg") (void)) (display -1))) + (not (cptypes-equivalent-expansion? + '(begin (if (box? (box 0)) (void) (error 'who "msg")) (display 1)) + '(begin (if (box? (box 0)) (void) (error 'who "msg")) (display -1)))) + (cptypes-equivalent-expansion? + '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (error 'who "msg")) (vector? x)) + '(lambda (x) (if (zero? (random 2)) (vector-set! x 0 0) (error 'who "msg")) #t)) + (cptypes-equivalent-expansion? + '(lambda (x) (if (zero? (random 2)) (error 'who "msg") (vector-set! x 0 0)) (vector? x)) + '(lambda (x) (if (zero? (random 2)) (error 'who "msg") (vector-set! x 0 0)) #t)) + (cptypes-equivalent-expansion? + '(begin (if (zero? (random 2)) (error 'who "msg") (error 'who "other")) (display 1)) + '(begin (if (zero? (random 2)) (error 'who "msg") (error 'who "other")) (display -1))) + (cptypes-equivalent-expansion? + '(lambda (x y) (if y (vector-set! x 0 0) (vector-set! x 0 1)) (vector? x)) + '(lambda (x y) (if y (vector-set! x 0 0) (vector-set! x 0 1)) #t)) + (not (cptypes-equivalent-expansion? + '(lambda (x y) (if y (void) (vector-set! x 0 0)) (vector? x)) + '(lambda (x y) (if y (void) (vector-set! x 0 0)) #t))) + (not (cptypes-equivalent-expansion? + '(lambda (x y) (if y (vector-set! x 0 0) (void)) (vector? x)) + '(lambda (x y) (if y (vector-set! x 0 0) (void)) #t))) + (cptypes-equivalent-expansion? + '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (vector? x) (void))) + '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) #t (void)))) + (cptypes-equivalent-expansion? + '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (vector? x) (void))) + '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) #t (void)))) + (not (cptypes-equivalent-expansion? + '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (void) (vector? x))) + '(lambda (x y) (if (if y (vector? x) (error 'who "msg")) (void) #t)))) + (not (cptypes-equivalent-expansion? + '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (void) (vector? x))) + '(lambda (x y) (if (if y (error 'who "msg") (vector? x)) (void) #t)))) + (cptypes-equivalent-expansion? + '(lambda (t) (vector? (if t (vector 1) (vector 2)))) + '(lambda (t) (if t (vector 1) (vector 2)) #t)) + (cptypes-equivalent-expansion? + '(number? (if t 1 2.0)) + '(begin (if t 1 2.0) #t)) + (cptypes-equivalent-expansion? + '(lambda (t) (fixnum? (if t 1 2))) + '(lambda (t) (if t 1 2.0) #t)) + (cptypes-equivalent-expansion? + '(lambda (t) (boolean? (if t #t #f))) + '(lambda (t) (if t #t #f) #t)) + (cptypes-equivalent-expansion? + '(lambda (t) ((lambda (x) (if x #t #f)) (if t (vector 1) (box 1)))) + '(lambda (t) (if t (vector 1) (box 1)) #t)) + (cptypes-equivalent-expansion? + '(lambda (t)(not (if t (vector 1) (box 1)))) + '(lambda (t) (if t (vector 1) (box 1)) #f)) + (cptypes-equivalent-expansion? + '(lambda (x y z f) + (let ([t (if x (vector 1) (box 1))]) + (if (if y t z) (f t 1) (f t 2)))) + '(lambda (x y z f) + (let ([t (if x (vector 1) (box 1))]) + (if (if y #t z) (f t 1) (f t 2))))) + (not (cptypes-equivalent-expansion? + '(lambda (x y z f) + (let ([t (vector? x)]) + (if (if y t z) (f t 1) (f t 2)))) + '(lambda (x y z f) + (let ([t (vector? x)]) + (if (if y #t z) (f t 1) (f t 2)))))) + (not (cptypes-equivalent-expansion? + '(lambda (x y z f) + (let ([t (vector? x)]) + (if (if y t z) (f t 1) (f t 2)))) + '(lambda (x y z f) + (let ([t (vector? x)]) + (if (if y #f z) (f t 1) (f t 2)))))) +) + +(define (test-chain/preamble/self preamble check-self? l) + (let loop ([l l]) + (if (null? l) + #t + (and (or (not check-self?) + (cptypes-equivalent-expansion? + `(let () + ,preamble + (lambda (x) (when (,(car l) x) (,(car l) x)))) + `(let () + ,preamble + (lambda (x) (when (,(car l) x) #t))))) + (let loop ([t (cdr l)]) + (if (null? t) + #t + (and (cptypes-equivalent-expansion? + `(let () + ,preamble + (lambda (x) (when (,(car l) x) (,(car t) x)))) + `(let () + ,preamble + (lambda (x) (when (,(car l) x) #t)))) + (not (cptypes-equivalent-expansion? + `(let () + ,preamble + (lambda (x) (when (,(car t) x) (,(car l) x)))) + `(let () + ,preamble + (lambda (x) (when (,(car t) x) #t))))) + (loop (cdr t))))) + (loop (cdr l)))))) + +(define (test-chain l) + (test-chain/preamble/self '(void) #t l)) + +(define (test-chain* l) + (test-chain/preamble/self '(void) #f l)) + +(define (test-chain/preamble preamble l) + (test-chain/preamble/self preamble #t l)) + +(define (test-chain*/preamble l) + (test-chain/preamble/self preamble #f l)) + +(define (test-disjoint/preamble/self preamble check-self? l) + (let loop ([l l]) + (if (null? l) + #t + (and (or (not check-self?) + (cptypes-equivalent-expansion? + `(let () + ,preamble + (lambda (x) (when (,(car l) x) (,(car l) x)))) + `(let () + ,preamble + (lambda (x) (when (,(car l) x) #t))))) + (let loop ([t (cdr l)]) + (if (null? t) + #t + (and (cptypes-equivalent-expansion? + `(let () + ,preamble + (lambda (x) (when (,(car l) x) (,(car t) x)))) + `(let () + ,preamble + (lambda (x) (when (,(car l) x) #f)))) + (cptypes-equivalent-expansion? + `(let () + ,preamble + (lambda (x) (when (,(car t) x) (,(car l) x)))) + `(let () + ,preamble + (lambda (x) (when (,(car t) x) #f)))) + (loop (cdr t))))) + (loop (cdr l)))))) + +(define (test-disjoint l) + (test-disjoint/preamble/self '(void) #t l)) + +(define (test-disjoint* l) + (test-disjoint/preamble/self '(void) #f l)) + +(define (test-disjoint/preamble preamble l) + (test-disjoint/preamble/self preamble #t l)) + +(define (test-disjoint*/preamble preamble l) + (test-disjoint/preamble/self preamble #f l)) + +(mat cptypes-type-implies? + (test-chain '((lambda (x) (eq? x 0)) fixnum? #;exact-integer? real? number?)) + (test-chain* '(fixnum? integer? real?)) + (test-chain* '(fixnum? exact? number?)) ; exact? may raise an error + (test-chain* '((lambda (x) (eq? x (expt 256 100))) real? number?)) ; bignum? + (test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?)) + (test-chain '(gensym? symbol?)) + (test-chain '(not boolean?)) + (test-chain '((lambda (x) (eq? x #t)) boolean?)) + (test-chain* '(record? #3%$record?)) + (test-chain* '((lambda (x) (eq? x car)) procedure?)) + (test-chain* '(record-type-descriptor? #3%$record?)) + (test-disjoint '(pair? box? #3%$record? number? + vector? string? bytevector? fxvector? symbol? + char? boolean? null? (lambda (x) (eq? x (void))) + eof-object? bwp-object? procedure?)) + (test-disjoint '(pair? box? real? gensym? not)) + (test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? x #t)))) + (test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? #t x)))) + (test-disjoint '((lambda (x) (eq? x 0)) (lambda (x) (eq? x 1)) flonum?)) + (test-disjoint '((lambda (x) (eqv? x 0.0)) (lambda (x) (eqv? x 1.0)) fixnum?)) + (test-disjoint* '(list? record? vector?)) + (not (test-disjoint* '(list? null?))) + (not (test-disjoint* '(list? pair?))) +) + +; use a gensym to make expansions equivalent +(define my-rec (gensym "my-rec")) +(mat cptypes-type-record? + ; define-record + (parameterize ([optimize-level 2]) + (cptypes-equivalent-expansion? + `(let () (define-record ,my-rec (a)) (lambda (x) (display (my-rec-a x)) (my-rec? x))) + `(let () (define-record ,my-rec (a)) (lambda (x) (display (my-rec-a x)) #t)))) + (parameterize ([optimize-level 2]) + (cptypes-equivalent-expansion? + `(let () (define-record ,my-rec (a)) (lambda (x) (set-my-rec-a! x 0) (my-rec? x))) + `(let () (define-record ,my-rec (a)) (lambda (x) (set-my-rec-a! x 0) #t)))) + (cptypes-equivalent-expansion? + `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x))) + `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) #t))) + (cptypes-equivalent-expansion? + `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2))) + `(let () (define-record ,my-rec (a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2)))) + + (test-chain/preamble `(define-record ,my-rec (a)) '(my-rec? #3%$record?)) + (test-chain/preamble `(begin + (define-record ,my-rec (a)) + (define-record ,(gensym "sub-rec") ,my-rec (b))) + '(sub-rec? my-rec? #3%$record?)) + (test-disjoint/preamble `(define-record ,my-rec (a)) '(my-rec? pair? null? not number?)) + (test-disjoint/preamble `(begin + (define-record ,my-rec (a)) + (define-record ,(gensym "other-rec") (a))) + '(my-rec? other-rec?)) + + ; define-record-type + (parameterize ([optimize-level 2]) + (cptypes-equivalent-expansion? + `(let () (define-record-type ,my-rec (fields a)) (lambda (x) (display (my-rec-a x)) (my-rec? x))) + `(let () (define-record-type ,my-rec (fields a)) (lambda (x) (display (my-rec-a x)) #t)))) + (parameterize ([optimize-level 2]) + (cptypes-equivalent-expansion? + `(let () (define-record-type ,my-rec (fields (mutable a))) (lambda (x) (my-rec-a-set! x 0) (my-rec? x))) + `(let () (define-record-type ,my-rec (fields (mutable a))) (lambda (x) (my-rec-a-set! x 0) #t)))) + (cptypes-equivalent-expansion? + `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x))) + `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) #t))) + (cptypes-equivalent-expansion? + `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2))) + `(let () (define-record-type ,my-rec (fields a)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2)))) + + (test-chain/preamble `(define-record-type ,my-rec (fields a)) '(my-rec? #3%$record?)) + #;(test-chain/preamble `(begin + (define-record-type ,my-rec (fields a)) + (define-record-type ,(gensym "sub-rec") (parent ,my-rec) (fields b))) + '(sub-rec? my-rec? #3%$record?)) + (test-disjoint/preamble `(define-record-type ,my-rec (fields a)) '(my-rec? pair? null? not number?)) + #;(test-disjoint/preamble `(begin + (define-record-type ,my-rec (fields a)) + (define-record-type ,(gensym "other-rec") (fields a))) + '(my-rec? other-rec?)) + + ; define-record-type (sealed #t) + (parameterize ([optimize-level 2]) + (cptypes-equivalent-expansion? + `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (lambda (x) (display (my-rec-a x)) (my-rec? x))) + `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (lambda (x) (display (my-rec-a x)) #t)))) + (parameterize ([optimize-level 2]) + (cptypes-equivalent-expansion? + `(let () (define-record-type ,my-rec (fields (mutable a)) (sealed #t)) (lambda (x) (my-rec-a-set! x 0) (my-rec? x))) + `(let () (define-record-type ,my-rec (fields (mutable a)) (sealed #t)) (lambda (x) (my-rec-a-set! x 0) #t)))) + (cptypes-equivalent-expansion? + `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (my-rec? x))) + `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) #t))) + (cptypes-equivalent-expansion? + `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (if x 1 2))) + `(let () (define-record-type ,my-rec (fields a) (sealed #t)) (let ([x (make-my-rec 0)]) (display (list x x)) (if #t 1 2)))) + + (test-chain/preamble `(define-record-type ,my-rec (fields a) (sealed #t)) '(my-rec? #3%$record?)) + #;(test-chain/preamble `(begin + (define-record-type ,my-rec (fields a)) + (define-record-type ,(gensym "sub-rec") (parent ,my-rec) (fields b) (sealed #t))) + '(sub-rec? my-rec? #3%$record?)) + (test-disjoint/preamble `(define-record-type ,my-rec (fields a) (sealed #t)) '(my-rec? pair? null? not number?)) + #;(test-disjoint/preamble `(begin + (define-record-type ,my-rec (fields a) (sealed #t)) + (define-record-type ,(gensym "other-rec") (fields a) (sealed #t))) + '(my-rec? other-rec?)) + #;(test-disjoint/preamble `(begin + (define-record-type ,my-rec (fields a) (sealed #t)) + (define-record-type ,(gensym "other-rec") (fields a))) + '(my-rec? other-rec?)) +) diff --git a/mats/record.ms b/mats/record.ms index c8aa0dcf15..1ea99ee6a3 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -6375,9 +6375,7 @@ (#3%$object-set! 'scheme-object b ,fixnum? g7)) (#2%list (#3%record? b g5) - (begin - (if (#3%record? b g6) (#2%void) (#3%$record-oops 'unbox b g6)) - (#3%$object-ref 'scheme-object b ,fixnum?))))))) + (#3%$object-ref 'scheme-object b ,fixnum?)))))) (equal? (let () (define build-box @@ -6407,13 +6405,9 @@ (record-mutator (make-record-type-descriptor name #f #f #f #f '#((mutable x))) 0))) (procedure? (useless 'useless-box-setter))))) - `(#2%procedure? - (let ([g0 (#2%make-record-type-descriptor 'useless-box-setter #f #f #f #f '#((mutable x)))]) - (lambda (g1 g2) - (if (#3%record? g1 g0) - (#2%void) - (#3%$record-oops 'moi g1 g0)) - (#3%$object-set! 'scheme-object g1 ,fixnum? g2))))) + `(begin + (#2%make-record-type-descriptor 'useless-box-setter #f #f #f #f '#((mutable x))) + #t)) (let () (define useless (lambda (name) @@ -8592,9 +8586,7 @@ (if b (frob-x x) 72))))) `(lambda (b) (if b - (begin - (#3%$record-oops 'frob-x 'x ',record-type-descriptor?) - (#3%$object-ref 'scheme-object 'x ,fixnum?)) + (#3%$record-oops 'frob-x 'x ',record-type-descriptor?) 72))) (equivalent-expansion? (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) diff --git a/s/Mf-base b/s/Mf-base index 8b0fd8ec97..6f9b430bc7 100644 --- a/s/Mf-base +++ b/s/Mf-base @@ -105,7 +105,7 @@ patch = patch # putting cpnanopass.patch early for maximum make --jobs=2 benefit patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\ - cp0.patch cpvalid.patch cpcommonize.patch cpletrec.patch\ + cp0.patch cpvalid.patch cptypes.patch cpcommonize.patch cpletrec.patch\ reloc.patch\ compile.patch fasl.patch syntax.patch env.patch\ read.patch interpret.patch ftype.patch strip.patch\ @@ -127,7 +127,7 @@ basesrc =\ strnum.ss bytevector.ss 5_4.ss 5_6.ss 5_7.ss\ event.ss 4.ss front.ss foreign.ss 6.ss print.ss newhash.ss\ format.ss date.ss 7.ss cafe.ss trace.ss engine.ss\ - interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cpcommonize.ss cpletrec.ss inspect.ss\ + interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cptypes.ss cpcommonize.ss cpletrec.ss inspect.ss\ enum.ss io.ss read.ss primvars.ss syntax.ss costctr.ss expeditor.ss\ exceptions.ss pretty.ss env.ss\ fasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss diff --git a/s/compile.ss b/s/compile.ss index 32eca11865..fb017f76af 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -647,6 +647,8 @@ (set! cpletrec-ran? #t) (let* ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))] [waste (check-prelex-flags x 'cp0)] + [x ($pass-time 'cptypes (lambda () (do-trace $cptypes x)))] + [waste (check-prelex-flags x 'cptypes)] [x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))] [waste (check-prelex-flags x 'cpletrec)]) x)) @@ -1469,7 +1471,8 @@ (let ([x ((run-cp0) (lambda (x) (set! cpletrec-ran? #t) - (let ([x ($pass-time 'cp0 (lambda () ($cp0 x)))]) + (let* ([x ($pass-time 'cp0 (lambda () ($cp0 x)))] + [x ($pass-time 'cptypes (lambda () ($cptypes x)))]) ($pass-time 'cpletrec (lambda () ($cpletrec x))))) x2)]) (if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))] diff --git a/s/cprep.ss b/s/cprep.ss index 5d22e50d3c..26665ac673 100644 --- a/s/cprep.ss +++ b/s/cprep.ss @@ -222,7 +222,7 @@ (let ([x ((run-cp0) (lambda (x) (set! cpletrec-ran? #t) - ($cpletrec ($cp0 x $compiler-is-loaded?))) + ($cpletrec ($cptypes ($cp0 x $compiler-is-loaded?)))) ($cpvalid x))]) (if cpletrec-ran? x ($cpletrec x)))))))) (unless (environment? env) diff --git a/s/cptypes.ss b/s/cptypes.ss new file mode 100644 index 0000000000..34244a1c22 --- /dev/null +++ b/s/cptypes.ss @@ -0,0 +1,1029 @@ +"cptypes.ss" +;;; cptypes.ss +;;; Copyright 1984-2017 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +#| +Notes: + - (cptypes ir ctxt types) -> (values ir ret types t-types f-types) + + arguments + ir: expression to be optimized + ctxt: 'effect 'test 'value + types: an immutable dictionary (currently an intmap). + The dictionary connects the counter of a prelex with the types + discovered previously. + (fxmap ([prelex-counter x] . 'pair) + ([prelex-counter y] . 'vector) + ([prelex-counter z] . `(quote 0))) + + results + ir: the optimized expression + ret: type of the result of the expression + types: like the types in the argument, with addition of the type discover + during the optimization of the expression + t-types: types to be used in case the expression is not #f, to be used in + the "then" branch of an if. + If left as #f it will be automatically replaced with a copy of + types by the wrapper. + This is usually only filled in a text context. + f-types: idem for the "else" branch. (if x (something) (here x is #f)) + + + - predicate: They may be: + * a symbol to indicate the type, like 'vector 'pair 'number + (there are a few fake values, in particular 'bottom is used to + signal that there is an error) + * a nanopass-quoted value that is okay-to-copy?, like + `(quote 0) `(quote 5) `(quote #t) `(quote '()) + (this doesn't includes `(quote )) + * a [normal] list ($record/rtd ) to signal that it's a + record of type + * a [normal] list ($record/ref ) to signal that it's a + record of a type that is stored in the variable + (these may collide with other records) + * TODO?: add something to indicate that x is a procedure to + create/setter/getter/predicate of a record of that type + + - Primitives are marked as procedures, without distinction. + - Most of the time I'm using eq? and eqv? as if they were equivalent. + I assume that the differences are hidden by unspecified behavior. + +|# + + +[define $cptypes +[let () + (import (nanopass)) + (include "base-lang.ss") + (include "fxmap.ss") + + (with-output-language (Lsrc Expr) + (define void-rec `(quote ,(void))) + (define true-rec `(quote #t)) + (define false-rec `(quote #f)) + (define null-rec `(quote ())) + (define empty-vector-rec `(quote #())) + (define empty-string-rec `(quote "")) + (define empty-bytevector-rec `(quote #vu8())) + (define empty-fxvector-rec `(quote #vfx())) + (define eof-rec `(quote #!eof)) + (define bwp-rec `(quote #!bwp)) + + (define (simple? e) ; Simplified version copied from cp0. TODO: copy the rest. + (nanopass-case (Lsrc Expr) e + [(quote ,d) #t] + [(ref ,maybe-src ,x) #t] + [(case-lambda ,preinfo ,cl* ...) #t] + [,pr #t] + [(moi) #t] + [(record-type ,rtd ,e) (simple? e)] + [else #f] + #;[else ($oops who "unrecognized record ~s" e)])) + + ; TODO: Remove discardable operations in e1. (vector (f) (g)) => (begin (f) (g)) + (define make-seq + ; ensures that the right subtree of the output seq is not a seq if the + ; second argument is similarly constrained, to facilitate result-exp + (lambda (ctxt e1 e2) + (if (simple? e1) + e2 + (if (and (eq? ctxt 'effect) (simple? e2)) + e1 + (let ([e1 (nanopass-case (Lsrc Expr) e1 + [(seq ,e11 ,e12) + (guard (simple? e12)) + e11] + [else e1])]) + (nanopass-case (Lsrc Expr) e2 + [(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)] + [else `(seq ,e1 ,e2)])))))) + + #;(define make-seq* ; requires at least one operand + (lambda (ctxt e*) + (if (null? (cdr e*)) + (car e*) + (make-seq ctxt (car e*) (make-seq* ctxt (cdr e*)))))) + ) + + (module (pred-env-empty + pred-env-add pred-env-remove/base pred-env-lookup + pred-env-intersect/base pred-env-union/super-base + pred-env-rebase + pred-intersect pred-union) + (import fxmap) + + (define pred-env-empty empty-fxmap) + + (define (pred-env-add/key types key pred) + (cond + [(and pred + (not (eq? pred 'ptr))) ; filter 'ptr to reduce the size + (let ([old (fxmap-ref types key #f)]) + (cond + [(not old) + (fxmap-set types key pred)] + [else (let ([new (pred-intersect old pred)]) + (if (eq? old new) + types + (fxmap-set types key new)))]))] + [else + types])) + + (define (pred-env-add types x pred) + (cond + [(and x (not (prelex-was-assigned x))) + (pred-env-add/key types (prelex-counter x) pred)] + [else types])) + + (define (pred-env-remove/base types x base) + (fxmap-remove/base types (prelex-counter x) base)) + + (define (pred-env-lookup types x) + (and (not (prelex-was-assigned x)) + (fxmap-ref types (prelex-counter x) #f))) + + ; This is conceptually the intersection of the types in `types` and `from` + ; but since 'ptr is not stored to save space and time, the implementation + ; looks like an union of the fxmaps. + ; [missing 'ptr] _and_ 'vector -> 'vector + ; 'box _and_ 'vector -> 'bottom + ; 'number _and_ 'exact-integer -> 'exact-integer + (define (pred-env-intersect/base types from base) + #;(display (list (fxmap-changes from) (fxmap-changes types))) + (cond + [(fx> (fxmap-changes from) (fxmap-changes types)) + (pred-env-intersect/base from types base)] + [else + (let ([ret types]) + (fxmap-for-each/diff (lambda (key x y) + (let ([z (fxmap-ref types key #f)]) + ;x-> from + ;y-> base + ;z-> types + (set! ret (pred-env-add/key ret key (pred-intersect x z))))) + (lambda (key x) + (set! ret (pred-env-add/key ret key x))) + (lambda (key x) (error 'pred-env-intersect/base "") (void)) + from + base) + ret)])) + + (define (pred-intersect x y) + (cond + [(predicate-implies? x y) x] + [(predicate-implies? y x) y] + [(or (predicate-implies-not? x y) + (predicate-implies-not? y x)) + 'bottom] + [(or (and (eq? x 'boolean) (eq? y 'true)) + (and (eq? y 'boolean) (eq? x 'true))) + true-rec] + [else (or x y)])) ; if there is no exact option, at least keep the old value + + ; This is conceptually the union of the types in `types` and `from` + ; but since 'ptr is not stored to save space and time, the implementation + ; looks like an intersection of the fxmaps. + ; [missing 'ptr] _or_ 'vector -> [missing 'ptr] + ; 'box _or_ 'boolean -> [missing 'ptr] + ; 'number _or_ 'exact-integer -> 'number + (define (pred-env-union/from from base types new-base) + ; Calculate the union of types and from, and intersect it with new-base + ; Iterate over the difference of from and base. + (let ([ret new-base]) + (fxmap-for-each/diff (lambda (key x y) + (let ([z (fxmap-ref types key #f)]) + ;x-> from + ;y-> base + ;z-> types + (set! ret (pred-env-add/key ret key (pred-union x z))))) + (lambda (key x) + (let ([z (fxmap-ref types key #f)]) + ;x-> from + ;z-> types + (set! ret (pred-env-add/key ret key (pred-union x z))))) + (lambda (key x) (error 'pred-env-union/base "") (void)) + from + base) + ret)) + + (define (pred-env-union/super-base types types/b + from from/b + base + new-base) + ; Calculate the union of types and from, and intersect it with new-base + ; Use the intermediate bases to minimize the amount of operations + ; required. In particular, base should be the base of types/b and from/b. + (let ([size-types (fx- (fxmap-changes types) (fxmap-changes base))] + [size-from (fx- (fxmap-changes from) (fxmap-changes base))] + [size-new (fx+ (fx- (fxmap-changes types) (fxmap-changes types/b)) + (fx- (fxmap-changes from) (fxmap-changes from/b)))]) + (cond + [(and (fx<= size-types size-from) (fx<= size-types size-new)) + (pred-env-union/from types base from new-base)] + [(fx<= size-from size-new) + (pred-env-union/from from base types new-base)] + [else + (let ([temp (pred-env-union/from from from/b types new-base)]) + (pred-env-union/from types types/b from temp))]))) + + (define (pred-union x y) + (cond + [(predicate-implies? y x) x] + [(predicate-implies? x y) y] + [(find (lambda (t) + (and (predicate-implies? x t) + (predicate-implies? y t))) + '(char null-or-pair $record + gensym symbol + fixnum exact-integer flonum real number + boolean true ptr))] ; ensure they are order from more restrictive to less restrictive + [else #f])) + + (define (pred-env-rebase types base new-base) + (let ([ret types]) + (fxmap-for-each/diff (lambda (key x y) + (let ([z (fxmap-ref types key #f)]) + ;x-> new-base + ;y-> base + ;z-> types + (if (eq? x z) + (set! ret (fxmap-reset/base ret key new-base)) + (set! ret (fxmap-advance/base ret key new-base))))) + (lambda (key x) + (let ([z (fxmap-ref types key #f)]) + ;x-> new-base + ;z-> types + (if (eq? x z) + (set! ret (fxmap-reset/base ret key new-base)) + (set! ret (fxmap-advance/base ret key new-base))))) + (lambda (key x) (error 'pred-env-rebase "") (void)) + new-base + base) + ret)) + ) + + (define (pred-env-add/ref types r pred) + (nanopass-case (Lsrc Expr) r + [(ref ,maybe-src ,x) + (pred-env-add types x pred)] + [else types])) + + ;copied from cp0.ss + (define (arity-okay? arity n) + (or (not arity) ; presumably system routine w/no recorded arity + (ormap + (lambda (a) + (or (fx= n a) + (and (fx< a 0) (fx>= n (fx- -1 a))))) + arity))) + + ;copied from cp0.ss + (define okay-to-copy? + (lambda (obj) + ; okay to copy obj if (eq? (faslin (faslout x)) x) => #t or (in the case of numbers and characters) + ; the value of (eq? x x) is unspecified + (or (symbol? obj) + (number? obj) + (char? obj) + (boolean? obj) + (null? obj) + (eqv? obj "") + (eqv? obj '#()) + (eqv? obj '#vu8()) + (eqv? obj '#vfx()) + (eq? obj (void)) + (eof-object? obj) + (bwp-object? obj) + (eq? obj '#6=#6#) + ($unbound-object? obj) + (record-type-descriptor? obj)))) ;removed in datum->predicate + + (define (datum->predicate d ir) + (cond + [(#3%$record? d) '$record] ;check first to avoid double representation of rtd + [(okay-to-copy? d) ir] + [(and (integer? d) (exact? d)) 'exact-integer] + [(pair? d) 'pair] + [(box? d) 'box] + [(vector? d) 'vector] + [(string? d) 'string] + [(bytevector? d) 'bytevector] + [(fxvector? d) 'fxvector] + [else #f])) + + (define (rtd->record-predicate rtd) + (cond + [(Lsrc? rtd) + (nanopass-case (Lsrc Expr) rtd + [(quote ,d) + (guard (record-type-descriptor? d)) + (list '$record/rtd d)] + [(ref ,maybe-src ,x) + (guard (not (prelex-was-assigned x))) + (list '$record/ref x)] + [(record-type ,rtd ,e) + (rtd->record-predicate e)] + [else '$record])] + [else '$record])) + + ; when extend is #f the result is a predicate that recognizes less values + ; than the one in name. This is useful for reductions like + ; (pred? x) ==> #t and (something x) ==> (#3%something x) + ; when extend is #t the result is a predicate that recognizes more values + ; than the one in name. This is useful for reductions like + ; (pred? x) ==> #f and (something x) ==> + ; in case the non extended version is not #f, the extended version must be not #f + (define (primref-name->predicate name extend?) + (case name + [pair? 'pair] + [box? 'box] + [$record? '$record] + [fixnum? 'fixnum] + [flonum? 'flonum] + [real? 'real] + [number? 'number] + [vector? 'vector] + [string? 'string] + [bytevector? 'bytevector] + [fxvector? 'fxvector] + [gensym? 'gensym] + [symbol? 'symbol] + [char? 'char] + [boolean? 'boolean] + [procedure? 'procedure] + [not false-rec] + [null? null-rec] + [eof-object? eof-rec] + [bwp-object? bwp-rec] + [list? (if (not extend?) null-rec 'null-or-pair)] + [else ((if extend? cdr car);--------------------------------------------------- + (case name + [(record? record-type-descriptor?) '(bottom . $record)] + [(integer? rational?) '(exact-integer . real)] + [(cflonum?) '(flonum . number)] + [else '(#f . #f)]))])) ; this is used only to detect predicates. + + ; nqm: no question mark + ; this is almost duplicated code, but with more cases + ; it's also useful to avoid the allocation + ; of the temporal strings to transform: vector -> vector? + (define (primref-name/nqm->predicate name extend?) + (case name + [pair 'pair] + [box 'box] + [$record '$record] + [fixnum 'fixnum] + [flonum 'flonum] + [real 'real] + [number 'number] + [vector 'vector] + [string 'string] + [bytevector 'bytevector] + [fxvector 'fxvector] + [gensym 'gensym] + [symbol 'symbol] + [char 'char] + [bottom 'bottom] ;pseudo-predicate + [ptr 'ptr] ;pseudo-predicate + [boolean 'boolean] + [procedure 'procedure] + [exact-integer 'exact-integer] ;fake-predicate + [void void-rec] ;fake-predicate + [null null-rec] + [eof-object eof-rec] + [bwp-object bwp-rec] + [list (if (not extend?) null-rec 'null-or-pair)] ;fake-predicate + [else ((if extend? cdr car);--------------------------------------------------- + (case name + [(record rtd) '(bottom . $record)] + [(bit length ufixnum pfixnum) '(bottom . fixnum)] + [(uint sub-uint) '(bottom . exact-integer)] + [(sint) '(fixnum . exact-integer)] + [(uinteger) '(bottom . real)] + [(integer rational) '(exact-integer . real)] + [(cflonum) '(flonum . number)] + [else '(bottom . ptr)]))])) ; this is used only to analyze the signatures. + + (define (primref->predicate pr extend?) + (primref-name->predicate (primref-name pr) extend?)) + + (define (check-constant-is? x pred?) + (nanopass-case (Lsrc Expr) x + [(quote ,d) (pred? d)] + [else #f])) + + ; strange properties of bottom here: + ; (implies? x bottom): only for x=bottom + ; (implies? bottom y): always + ; (implies-not? x bottom): never + ; (implies-not? bottom y): never + ; check (implies? x bottom) before (implies? x something) + (define (predicate-implies? x y) + (and x + y + (or (eq? x y) + (and (Lsrc? x) + (Lsrc? y) + (nanopass-case (Lsrc Expr) x + [(quote ,d1) + (nanopass-case (Lsrc Expr) y + [(quote ,d2) (eqv? d1 d2)] #;CHECK ;eq?/eqv?/equal? + [else #f])] + [else #f])) + (and (pair? x) (pair? (cdr x)) (eq? (car x) '$record/rtd) + (pair? y) (pair? (cdr y)) (eq? (car y) '$record/rtd) + (cond + [(record-type-sealed? (cadr y)) + (eqv? (cadr x) (cadr y))] + [else + (let loop ([x (cadr x)] [y (cadr y)]) + (or (eqv? x y) + (let ([xp (record-type-parent x)]) + (and xp (loop xp y)))))])) + (and (pair? x) (pair? (cdr x)) (eq? (car x) '$record/ref) + (pair? y) (pair? (cdr y)) (eq? (car y) '$record/ref) + (eq? (cadr x) (cadr y))) + (eq? x 'bottom) + (case y + [(null-or-pair) (or (check-constant-is? x null?) + (eq? x 'pair))] + [(fixnum) (check-constant-is? x target-fixnum?)] + [(exact-integer) + (or (eq? x 'fixnum) + (check-constant-is? x (lambda (x) (and (integer? x) + (exact? x)))))] + [(flonum) (check-constant-is? x flonum?)] + [(real) (or (eq? x 'fixnum) + (eq? x 'exact-integer) + (eq? x 'flonum) + (check-constant-is? x real?))] + [(number) (or (eq? x 'fixnum) + (eq? x 'exact-integer) + (eq? x 'flonum) + (eq? x 'real) + (check-constant-is? x number?))] + [(gensym) (check-constant-is? x gensym?)] + [(symbol) (or (eq? x 'gensym) + (check-constant-is? x symbol?))] + [(char) (check-constant-is? x char?)] + [(boolean) (or (check-constant-is? x not) + (check-constant-is? x (lambda (x) (eq? x #t))))] + [(true) (and (not (check-constant-is? x not)) + (not (eq? x 'boolean)) + (not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f + [($record) (or (check-constant-is? x #3%$record?) + (and (pair? x) (eq? (car x) '$record/rtd)) + (and (pair? x) (eq? (car x) '$record/ref)))] + [(vector) (check-constant-is? x vector?)] ; i.e. '#() + [(string) (check-constant-is? x string?)] ; i.e. "" + [(bytevector) (check-constant-is? x bytevector?)] ; i.e. '#vu8() + [(fxvector) (check-constant-is? x fxvector?)] ; i.e. '#vfx() + [(ptr) #t] + [else #f])))) + + (define (predicate-implies-not? x y) + (and x + y + ; a $record/ref may be any other kind or record + (not (and (pair? x) + (eq? (car x) '$record/ref) + (predicate-implies? y '$record))) + (not (and (pair? y) + (eq? (car y) '$record/ref) + (predicate-implies? x '$record))) + ; boolean and true may be #f + (not (and (eq? x 'boolean) + (eq? y 'true))) + (not (and (eq? y 'boolean) + (eq? x 'true))) + ; the other types are included or disjoint + (not (predicate-implies? x y)) + (not (predicate-implies? y x)))) + + (define (signature->result-predicate signature) + (let ([results (cdr signature)]) + (and (fx= (length results) 1) + (let ([result (car results)]) + (cond + [(symbol? result) + (primref-name/nqm->predicate result #t)] + [(equal? result '(ptr . ptr)) + 'pair] + [(pair? result) + 'pair] + [else + 'ptr]))))) + + (define primref->result-predicate/cache (make-hashtable equal-hash equal?)) + + (define (primref->result-predicate pr) + (let ([key (primref-name pr)]) + (if (hashtable-contains? primref->result-predicate/cache key) + (hashtable-ref primref->result-predicate/cache key #f) + (let ([new (primref->result-predicate/no-cache pr)]) + (hashtable-set! primref->result-predicate/cache key new) + new)))) + + (define (primref->result-predicate/no-cache pr) + (let ([pred/flags + (let ([flags (primref-flags pr)]) + (cond + [(all-set? (prim-mask abort-op) flags) + 'bottom] + [(all-set? (prim-mask true) flags) + 'true] + [(all-set? (prim-mask boolean-valued) flags) + 'boolean] + [else + #f]))] + [pred/signatures + (let ([signatures (primref-signatures pr)]) + (and (not (null? signatures)) + (let ([results (map (lambda (s) (signature->result-predicate s)) signatures)]) + (fold-left pred-union 'bottom results))))]) + (pred-intersect pred/flags pred/signatures))) + + (define (signature->argument-predicate signature pos extend?) + (let* ([arguments (car signature)] + [dots (memq '... arguments)]) + (cond + [(and dots (null? (cdr dots))) + (cond + [(< pos (- (length arguments) 2)) + (primref-name/nqm->predicate (list-ref arguments pos) extend?)] + [else + (primref-name/nqm->predicate (list-ref arguments (- (length arguments) 2)) extend?)])] + [dots #f] ; TODO: Extend to handle this case, perhaps knowing the argument count. + [else + (cond + [(< pos (length arguments)) + (let ([argument (list-ref arguments pos)]) + (cond + [(equal? argument '(ptr . ptr)) + 'pair] + [(and extend? (pair? argument)) + 'pair] + [else + (primref-name/nqm->predicate argument extend?)]))] + [else + 'bottom])]))) + + (define primref->argument-predicate/cache (make-hashtable equal-hash equal?)) + + (define (primref->argument-predicate pr pos extend?) + (let ([key (list (primref-name pr) pos extend?)]) + (if (hashtable-contains? primref->argument-predicate/cache key) + (hashtable-ref primref->argument-predicate/cache key #f) + (let ([new (primref->argument-predicate/no-cache pr pos extend?)]) + (when (<= pos 10) + (hashtable-set! primref->argument-predicate/cache key new)) + new)))) + + (define (primref->argument-predicate/no-cache pr pos extend?) + (let ([signatures (primref-signatures pr)]) + (and (>= (length signatures) 1) + (let ([vals (map (lambda (signature) + (signature->argument-predicate signature pos extend?)) + signatures)]) + (fold-left (if extend? pred-union pred-intersect) (car vals) (cdr vals)))))) + + [define-pass cptypes/raw : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types) + [Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types) + [(quote ,d) + (values ir (datum->predicate d ir) #f #f #f)] + [(ref ,maybe-src ,x) + (case ctxt + [(test) + (let ([t (pred-env-lookup types x)]) + (cond + [(predicate-implies-not? t false-rec) + (values true-rec true-rec #f #f #f)] + [(predicate-implies? t false-rec) + (values false-rec false-rec #f #f #f)] + [else + (values ir t + types + (pred-env-add/ref types ir 'true) ; don't confuse it with true-rec + (pred-env-add/ref types ir false-rec))]))] + [else + (let ([t (pred-env-lookup types x)]) + (cond + [(Lsrc? t) + (nanopass-case (Lsrc Expr) t + [(quote ,d) + (values t t #f #f #f)] + [else + (values ir t #f #f #f)])] + [else + (values ir t #f #f #f)]))])] + [(seq ,e1 ,e2) + (let-values ([(e1 ret1 types t-types f-types) + (cptypes e1 'effect types)]) + (cond + [(predicate-implies? ret1 'bottom) + (values e1 ret1 types #f #f)] + [else + (let-values ([(e2 ret types t-types f-types) + (cptypes e2 ctxt types)]) + (values (make-seq ctxt e1 e2) ret types t-types f-types))]))] + [(if ,e1 ,e2 ,e3) + (let-values ([(e1 ret1 types1 t-types1 f-types1) + (cptypes e1 'test types)]) + (cond + [(predicate-implies? ret1 'bottom) ;check bottom first + (values e1 ret1 types #f #f)] + [(predicate-implies-not? ret1 false-rec) + (let-values ([(e2 ret types t-types f-types) + (cptypes e2 ctxt types)]) + (values (make-seq ctxt e1 e2) ret types t-types f-types))] + [(predicate-implies? ret1 false-rec) + (let-values ([(e3 ret types t-types f-types) + (cptypes e3 ctxt types)]) + (values (make-seq ctxt e1 e3) ret types t-types f-types))] + [else + (let-values ([(e2 ret2 types2 t-types2 f-types2) + (cptypes e2 ctxt t-types1)] + [(e3 ret3 types3 t-types3 f-types3) + (cptypes e3 ctxt f-types1)]) + (let ([ir `(if ,e1 ,e2 ,e3)]) + (cond + [(predicate-implies? ret2 'bottom) ;check bottom first + (values ir ret3 types3 t-types3 f-types3)] + [(predicate-implies? ret3 'bottom) ;check bottom first + (values ir ret2 types2 t-types2 f-types2)] + [else + (let ([new-types (pred-env-union/super-base types2 t-types1 + types3 f-types1 + types1 + types1)]) + (values ir + (cond + [(and (eq? ctxt 'test) + (predicate-implies-not? ret2 false-rec) + (predicate-implies-not? ret3 false-rec)) + true-rec] + [else + (pred-union ret2 ret3)]) + new-types + (cond + [(not (eq? ctxt 'test)) + #f] ; don't calculate t-types outside a test context + [(predicate-implies? ret2 false-rec) + (pred-env-rebase t-types3 types1 new-types)] + [(predicate-implies? ret3 false-rec) + (pred-env-rebase t-types2 types1 new-types)] + [(and (eq? types2 t-types2) + (eq? types3 t-types3)) + #f] ; don't calculate t-types when it will be equal to new-types + [else + (pred-env-union/super-base t-types2 t-types1 + t-types3 f-types1 + types1 + new-types)]) + (cond + [(not (eq? ctxt 'test)) + #f] ; don't calculate f-types outside a test context + [(predicate-implies-not? ret2 false-rec) + (pred-env-rebase f-types3 types1 new-types)] + [(predicate-implies-not? ret3 false-rec) + (pred-env-rebase f-types2 types1 new-types)] + [(and (eq? types2 f-types2) + (eq? types3 f-types3)) + #f] ; don't calculate t-types when it will be equal to new-types + [else + (pred-env-union/super-base f-types2 t-types1 + f-types3 f-types1 + types1 + new-types)])))])))]))] + [(set! ,maybe-src ,x ,e) + (let-values ([(e ret types t-types f-types) + (cptypes e 'value types)]) + (values `(set! ,maybe-src ,x ,e) + void-rec types #f #f))] + [(call ,preinfo ,pr ,e* ...) + (let* ([e/r/t* (map (lambda (e) + (let-values ([(e r t t-t f-t) + (cptypes e 'value types)]) + (list e r t))) + e*)] + [e* (map car e/r/t*)] + [r* (map cadr e/r/t*)] + [t* (map caddr e/r/t*)] + [t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] + [ret (primref->result-predicate pr)] + [ir `(call ,preinfo ,pr ,e* ...)]) + (let-values ([(ret t) + (let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t]) + (if (null? e*) + (values ret t) + (let ([pred (primref->argument-predicate pr n #t)]) + (loop (cdr e*) + (cdr r*) + (fx+ n 1) + (if (predicate-implies-not? (car r*) pred) + 'bottom + ret) + (pred-env-add/ref t (car e*) pred)))))]) + (cond + [(predicate-implies? ret 'bottom) + (values ir ret t #f #f)] + [(not (arity-okay? (primref-arity pr) (length e*))) + (values ir 'bottom t #f #f)] + [(and (fx= (length e*) 2) + (or (eq? (primref-name pr) 'eq?) + (eq? (primref-name pr) 'eqv?))) + (let ([r1 (car r*)] + [r2 (cadr r*)] + [e1 (car e*)] + [e2 (cadr e*)]) + (cond + [(or (predicate-implies-not? r1 r2) + (predicate-implies-not? r2 r1)) + (values (make-seq ctxt (make-seq 'effect e1 e2) false-rec) + false-rec t #f #f)] + [else + (values ir ret types + (and (eq? ctxt 'test) + (pred-env-add/ref + (pred-env-add/ref t e1 r2) + e2 r1)) + #f)]))] + [(and (fx= (length e*) 1) + (primref->predicate pr #t)) + (let ([var (car r*)] + [pred (primref->predicate pr #f)]) + (cond + [(predicate-implies? var pred) + (values (make-seq ctxt (car e*) true-rec) + true-rec t #f #f)] + [else + (let ([pred (primref->predicate pr #t)]) + (cond + [(predicate-implies-not? var pred) + (values (make-seq ctxt (car e*) false-rec) + false-rec t #f #f)] + [else + (values ir ret types + (and (eq? ctxt 'test) + (pred-env-add/ref t (car e*) pred)) + #f)]))]))] + [(and (fx>= (length e*) 1) + (eq? (primref-name pr) '$record)) + (values ir (rtd->record-predicate (car e*)) t #f #f)] + [(and (fx= (length e*) 2) + (or (eq? (primref-name pr) 'record?) + (eq? (primref-name pr) '$sealed-record?))) + (let ([pred (rtd->record-predicate (cadr e*))] + [var (car r*)]) + (cond + [(predicate-implies-not? var pred) + (cond + [(or (all-set? (prim-mask unsafe) (primref-flags pr)) + (nanopass-case (Lsrc Expr) (cadr e*) ; ensure that it is actually a rtd + [(quote ,d) + (record-type-descriptor? d)] + [(record-type ,rtd ,e) #t] + [else #f])) + (values (make-seq ctxt (make-seq 'effect (car e*) (cadr e*)) false-rec) + false-rec t #f #f)] + [else + (values (make-seq ctxt ir false-rec) + false-rec t #f #f)])] + [(and (not (eq? pred '$record)) ; assume that the only extension is '$record + (predicate-implies? var pred)) + (values (make-seq ctxt (make-seq 'effect (car e*) (cadr e*)) true-rec) + true-rec t #f #f)] + [else + (values ir ret types + (and (eq? ctxt 'test) + (pred-env-add/ref types (car e*) pred)) + #f)]))] + ; TODO: special case for call-with-values. + [(and (fx= (length e*) 1) + (eq? (primref-name pr) 'exact?)) + (cond + [(predicate-implies? (car r*) 'exact-integer) + (values (make-seq ctxt (car e*) true-rec) + true-rec t #f #f)] + [(predicate-implies? (car r*) 'flonum) + (values (make-seq ctxt (car e*) false-rec) + false-rec t #f #f)] + [else + (values ir ret t #f #f)])] + [(and (fx= (length e*) 1) + (eq? (primref-name pr) 'inexact?)) + (cond + [(predicate-implies? (car r*) 'exact-integer) + (values (make-seq ctxt (car e*) false-rec) + false-rec t #f #f)] + [(predicate-implies? (car r*) 'flonum) + (values (make-seq ctxt (car e*) true-rec) + true-rec t #f #f)] + [else + (values ir ret t #f #f)])] + [else + (values ir ret t #f #f)])))] + [(case-lambda ,preinfo ,cl* ...) + (let ([cl* (map (lambda (cl) + (nanopass-case (Lsrc CaseLambdaClause) cl + [(clause (,x* ...) ,interface ,body) + (let-values ([(body ret types t-types f-types) + (cptypes body 'value types)]) + (with-output-language (Lsrc CaseLambdaClause) + `(clause (,x* ...) ,interface ,body)))])) + cl*)]) + (values `(case-lambda ,preinfo ,cl* ...) 'procedure #f #f #f))] + [(call ,preinfo ,e0 ,e* ...) + (let* ([e/r/t* (map (lambda (e) + (let-values ([(e r t t-t f-t) + (cptypes e 'value types)]) + (list e r t))) + e*)] + [e* (map car e/r/t*)] + [r* (map cadr e/r/t*)] + [t* (map caddr e/r/t*)] + [t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]) + (nanopass-case (Lsrc Expr) e0 + [(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) + ; We are sure that body will run and that it will be run after the evaluation of the arguments, + ; so we can use the types discovered in the arguments and also use the ret and types from the body. + (guard (fx= interface (length e*))) + (let ([t (fold-left pred-env-add t x* r*)]) + (let-values ([(body ret n-types t-types f-types) + (cptypes body ctxt t)]) + (let* ([e0 `(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body))] + [new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] + [t-types (and (eq? ctxt 'test) + (not (eq? n-types t-types)) + (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] + [f-types (and (eq? ctxt 'test) + (not (eq? n-types f-types)) + (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) + (values `(call ,preinfo ,e0 ,e* ...) + ret new-types t-types f-types))))] + [(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) + ; We are sure that body will run and that it will be run after the evaluation of the arguments, + ; but this will raise an error. TODO: change body to (void) because it will never run. + (guard (not (fx= interface (length e*)))) + (let-values ([(body ret types t-types f-types) + (cptypes body 'value t)]) + (let ([e0 `(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body))]) + (values `(call ,preinfo ,e0 ,e* ...) + 'bottom #f #f #f)))] + [(case-lambda ,preinfo2 ,cl* ...) + ; We are sure that it will run after the arguments are evaluated, + ; so we can effectively delay the evaluation of the lambda and use more types inside it. + ; TODO: (difficult) Try to use the ret vales and discovered types. + (let-values ([(e0 ret types t-types f-types) + (cptypes e0 'value t)]) + (values `(call ,preinfo ,e0 ,e* ...) + #f t #f #f))] + [else + ; It's difficult to be sure the order the code will run, + ; so assume that the expression may be evaluated before the arguments. + (let-values ([(e0 ret0 types0 t-types0 f-types0) + (cptypes e0 'value types)]) + (let* ([t (pred-env-intersect/base t types0 types)] + [t (pred-env-add/ref t e0 'procedure)]) + (values `(call ,preinfo ,e0 ,e* ...) + #f t #f #f)))]))] + [(letrec ((,x* ,e*) ...) ,body) + (let* ([e/r/t* (map (lambda (e) + (let-values ([(e ret types t-types f-types) + (cptypes e 'value types)]) + (list e ret types))) + e*)] + [e* (map car e/r/t*)] + [r* (map cadr e/r/t*)] + [t* (map caddr e/r/t*)] + [t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] + [t (fold-left pred-env-add t x* r*)]) + (let-values ([(body ret n-types t-types f-types) + (cptypes body ctxt t)]) + (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] + [t-types (and (eq? ctxt 'test) + (not (eq? n-types t-types)) + (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] + [f-types (and (eq? ctxt 'test) + (not (eq? n-types f-types)) + (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) + (values `(letrec ([,x* ,e*] ...) ,body) + ret new-types t-types f-types))))] + [(letrec* ((,x* ,e*) ...) ,body) + (let*-values ([(e* types) + (let loop ([x* x*] [e* e*] [types types] [rev-e* '()]) ; this is similar to an ordered-map + (if (null? x*) + (values (reverse rev-e*) types) + (let-values ([(e ret types t-types f-types) + (cptypes (car e*) 'value types)]) + (let ([types (pred-env-add types (car x*) ret)]) + (loop (cdr x*) (cdr e*) types (cons e rev-e*))))))]) + (let-values ([(body ret n-types t-types f-types) + (cptypes body ctxt types)]) + (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] + [t-types (and (eq? ctxt 'test) + (not (eq? n-types t-types)) + (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] + [f-types (and (eq? ctxt 'test) + (not (eq? n-types f-types)) + (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) + (values `(letrec* ([,x* ,e*] ...) ,body) + ret new-types t-types f-types))))] + [,pr + (values ir + (and (all-set? (prim-mask proc) (primref-flags pr)) 'procedure) + #f #f #f)] + [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) + (let-values ([(e ret types t-types f-types) + (cptypes e 'value types)]) + (values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) + #f types #f #f))] + [(fcallable ,conv ,e (,arg-type* ...) ,result-type) + (let-values ([(e ret types t-types f-types) + (cptypes e 'value types)]) + (values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) + #f types #f #f))] + [(record ,rtd ,rtd-expr ,e* ...) + (let-values ([(rtd-expr ret-re types-re t-types-re f-types-re) + (cptypes rtd-expr 'value types)]) + (let* ([e/r/t* (map (lambda (e) + (let-values ([(e ret types t-types f-types) + (cptypes e 'value types)]) + (list e ret types))) + e*)] + [e* (map car e/r/t*)] + #;[r* (map cadr e/r/t*)] + [t* (map caddr e/r/t*)]) + (values `(record ,rtd ,rtd-expr ,e* ...) + (rtd->record-predicate rtd-expr) + (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*) + #f #f)))] + [(record-ref ,rtd ,type ,index ,e) + (let-values ([(e ret types t-types f-types) + (cptypes e 'value types)]) + (values `(record-ref ,rtd ,type ,index ,e) + #f + (pred-env-add/ref types e '$record) + #f #f))] + [(record-set! ,rtd ,type ,index ,e1 , e2) ;can they be reordered? + (let-values ([(e1 ret1 types1 t-types1 f-types1) + (cptypes e1 'value types)] + [(e2 ret2 types2 t-types2 f-types2) + (cptypes e2 'value types)]) + (values `(record-set! ,rtd ,type ,index ,e1 ,e2) + void-rec + (pred-env-add/ref (pred-env-intersect/base types1 types2 types) + e1 '$record) + #f #f))] + [(record-type ,rtd ,[cptypes : e 'value types -> e ret types t-types f-types]) + (values `(record-type ,rtd ,e) + #f types #f #f)] + [(record-cd ,rcd ,rtd-expr ,[cptypes : e 'value types -> e ret types t-types f-types]) + (values `(record-cd ,rcd ,rtd-expr ,e) + #f types #f #f)] + [(immutable-list (,e* ...) ,e) + (let ([e* (map (lambda (e) + (let-values ([(e ret types t-types f-types) + (cptypes e 'value types)]) + e)) + e*)]) + (let-values ([(e ret types t-types f-types) + (cptypes e 'value types)]) + (values `(immutable-list (,e* ...) ,e) + ret types #f #f)))] #;CHECK + [(moi) (values ir #f #f #f #f)] + [(pariah) (values ir void-rec #f #f #f)] + [(cte-optimization-loc ,box ,e) + (let-values ([(e ret types t-types f-types) + (cptypes e 'value types)]) + (values `(cte-optimization-loc ,box ,e) + ret types #f #f))] #;CHECK + [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] + [(profile ,src) (values ir #f #f #f #f)] + #;[else (values ir #f #f #f #f)] + [else ($oops who "unrecognized record ~s" ir)]] + (Expr ir ctxt types)] + + (define (cptypes ir ctxt types) + (let-values ([(ir ret r-types t-types f-types) + (cptypes/raw ir ctxt types)]) + (values ir + ret + (or r-types types) + (or t-types r-types types) + (or f-types r-types types)))) + (lambda (ir) + (let-values ([(ir ret types t-types f-types) + (cptypes ir 'value pred-env-empty)]) + ir)) +]] diff --git a/s/front.ss b/s/front.ss index 1ca36b0769..ad4dc30c87 100644 --- a/s/front.ss +++ b/s/front.ss @@ -214,6 +214,7 @@ (package-stubs compiler-support $cp0 $cpvalid + $cptypes $cpletrec $cpcheck) (package-stubs syntax-support diff --git a/s/interpret.ss b/s/interpret.ss index d019327f12..aa1281f333 100644 --- a/s/interpret.ss +++ b/s/interpret.ss @@ -654,7 +654,7 @@ (let ([x ((run-cp0) (lambda (x) (set! cpletrec-ran? #t) - ($cpletrec ($cp0 x #f))) + ($cpletrec ($cptypes ($cp0 x #f)))) x2)]) (if cpletrec-ran? x ($cpletrec x))))] [x2b ($cpcheck x2a)] diff --git a/s/primdata.ss b/s/primdata.ss index 6f719e2eda..ee2a267a23 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1765,6 +1765,7 @@ ($continuation-winders [flags]) ($cp0 [flags]) ($cpcheck [flags]) + ($cptypes [flags]) ($cpcheck-prelex-flags [flags]) ($cpcommonize [flags]) ($cpletrec [flags]) From 05c81335a4c7cf39f9b60a9eee2e3741cf4d2ad4 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Tue, 16 Jan 2018 00:18:30 -0300 Subject: [PATCH 06/11] Add safeongoodargs flag to primref for example reduce (car ) => (#3%car ) original commit: fedfc84d6abf348f9d2579d479b08f727eb7d445 --- mats/4.ms | 6 +- mats/cp0.ms | 8 +- mats/cptypes.ms | 30 ++++ mats/misc.ms | 2 +- mats/record.ms | 4 +- s/cmacros.ss | 1 + s/cptypes.ss | 34 ++++ s/primdata.ss | 446 ++++++++++++++++++++++++------------------------ 8 files changed, 298 insertions(+), 233 deletions(-) diff --git a/mats/4.ms b/mats/4.ms index 3d531e227f..b91986a6e8 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -1304,9 +1304,9 @@ (list 'b 'u 'y) (list 'c 'v 'z)))) '(#2%list - (#2%string->symbol (#2%string-append "a" "b" "c")) - (#2%string->symbol (#2%string-append "t" "u" "v")) - (#2%string->symbol (#2%string-append "x" "y" "z")))) + (#3%string->symbol (#3%string-append "a" "b" "c")) + (#3%string->symbol (#3%string-append "t" "u" "v")) + (#3%string->symbol (#3%string-append "x" "y" "z")))) (equivalent-expansion? (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize diff --git a/mats/cp0.ms b/mats/cp0.ms index e1755e7b57..d50dd49029 100644 --- a/mats/cp0.ms +++ b/mats/cp0.ms @@ -815,13 +815,13 @@ (lambda (r) (emit-word! 2953052161) (emit-word! 3766812992) - (emit-word! (#2%+ 3766747136 (#2%ash r 0)))))) + (emit-word! (#3%+ 3766747136 (#2%ash r 0)))))) (syntax-case x ($primitive) [(set! test (lambda (r1) (ew1! 2953052161) (ew2! 3766812992) - (ew3! (#2%+ 3766747136 (#2%ash r2 0))))) + (ew3! (#3%+ 3766747136 (#2%ash r2 0))))) (eq? #'r1 #'r2)]))) ; verify optimization of (if e s s) => (begin e s) (equivalent-expansion? @@ -859,14 +859,14 @@ (expand/optimize '(lambda (x y) (if (not (or (fx< x y) (fx> y x))) x y)))) '(lambda (x.0 y.1) - (if (if (#2%fx< x.0 y.1) #t (#2%fx> y.1 x.0)) + (if (if (#2%fx< x.0 y.1) #t (#3%fx> y.1 x.0)) y.1 x.0))) (equivalent-expansion? (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2]) (expand/optimize '(lambda (x y) (if (or (fx< x y) (fx> y x)) x y)))) - '(lambda (x y) (if (if (#2%fx< x y) #t (#2%fx> y x)) x y))) + '(lambda (x y) (if (if (#2%fx< x y) #t (#3%fx> y x)) x y))) (equivalent-expansion? (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 2]) (expand/optimize diff --git a/mats/cptypes.ms b/mats/cptypes.ms index 8562b48e94..f7fa5512e5 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -516,3 +516,33 @@ (define-record-type ,(gensym "other-rec") (fields a))) '(my-rec? other-rec?)) ) + +(mat cptypes-unsafe + (cptypes-equivalent-expansion? + '(lambda (x) (when (pair? x) (car x))) + '(lambda (x) (when (pair? x) (#3%car x)))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (pair? x) (cdr x))) + '(lambda (x) (when (pair? x) (#3%cdr x)))) + (not (cptypes-equivalent-expansion? + '(lambda (x) (when (pair? x) (#2%cadr x))) + '(lambda (x) (when (pair? x) (#3%cadr x))))) + (cptypes-equivalent-expansion? + '(lambda (x y) (when (and (fixnum? x) (fixnum? y)) (fxmax x y))) + '(lambda (x y) (when (and (fixnum? x) (fixnum? y)) (#3%fxmax x y)))) + (cptypes-equivalent-expansion? + '(lambda (x y) (when (and (fixnum? x) (eq? y 5)) (fxmax x y))) + '(lambda (x y) (when (and (fixnum? x) (eq? y 5)) (#3%fxmax x y)))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (fixnum? x) (fxmax x 5))) + '(lambda (x) (when (fixnum? x) (#3%fxmax x 5)))) + (cptypes-equivalent-expansion? + '(lambda (x y z) (when (and (fixnum? x) (fixnum? y) (fixnum? z)) (fxmax x y z))) + '(lambda (x y z) (when (and (fixnum? x) (fixnum? y) (fixnum? z)) (#3%fxmax x y z)))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (fixnum? x) (fxzero? x))) + '(lambda (x) (when (fixnum? x) (#3%fxzero? x)))) + (not (cptypes-equivalent-expansion? + '(lambda (x) (when (number? x) (#2%odd? x))) + '(lambda (x) (when (number? x) (#3%odd? x))))) +) diff --git a/mats/misc.ms b/mats/misc.ms index 20250b3332..a56a2f4032 100644 --- a/mats/misc.ms +++ b/mats/misc.ms @@ -4876,7 +4876,7 @@ '(if (#3%zero? (#3%random 1000)) (begin (pariah (void)) (#3%display 0)) (#3%display 1)) - '(if (#2%zero? (#2%random 1000)) + '(if (#3%zero? (#2%random 1000)) (begin (pariah (void)) (#2%display 0)) (#2%display 1)))) ) diff --git a/mats/record.ms b/mats/record.ms index 1ea99ee6a3..6a8ce14687 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -8785,7 +8785,7 @@ [r (inc r)] [r (inc r)]) r))))) - `(lambda (x) (#3%$record ',record-type-descriptor? 37 (#2%+ 1 (#2%+ 1 x))))) + `(lambda (x) (#3%$record ',record-type-descriptor? 37 (#3%+ 1 (#2%+ 1 x))))) (equivalent-expansion? (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize @@ -8812,7 +8812,7 @@ [r (inc r)]) r))))) '(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable a) (immutable b)) 'define-record-type)]) - (lambda (x) (#3%$record rtd 37 (#2%+ 1 (#2%+ 1 x)))))) + (lambda (x) (#3%$record rtd 37 (#3%+ 1 (#2%+ 1 x)))))) (equivalent-expansion? (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize diff --git a/s/cmacros.ss b/s/cmacros.ss index b039789202..06cfc1e7c4 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -1569,6 +1569,7 @@ (boolean-valued #b00000010000000000000000) (abort-op #b00000100000000000000000) (unsafe #b00001000000000000000000) + (safeongoodargs #b00010000000000000000000) (arith-op (or proc pure true)) (alloc (or proc discard true)) ; would be nice to check that these and only these actually have cp0 partial folders diff --git a/s/cptypes.ss b/s/cptypes.ss index 34244a1c22..0cb073690c 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -597,6 +597,9 @@ Notes: signatures)]) (fold-left (if extend? pred-union pred-intersect) (car vals) (cdr vals)))))) + (define (primref->unsafe-primref pr) + (lookup-primref 3 (primref-name pr))) + [define-pass cptypes/raw : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types) [Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types) [(quote ,d) @@ -803,6 +806,18 @@ Notes: (predicate-implies? var pred)) (values (make-seq ctxt (make-seq 'effect (car e*) (cadr e*)) true-rec) true-rec t #f #f)] + [(and (not (all-set? (prim-mask unsafe) (primref-flags pr))) + (nanopass-case (Lsrc Expr) (cadr e*) ; check that it is a rtd + [(quote ,d) + (record-type-descriptor? d)] + [(record-type ,rtd ,e) #t] + [else #f])) + (let ([pr (primref->unsafe-primref pr)]) + (values `(call ,preinfo ,pr ,e* ...) + ret types + (and (eq? ctxt 'test) + (pred-env-add/ref types (car e*) pred)) + #f))] [else (values ir ret types (and (eq? ctxt 'test) @@ -818,6 +833,11 @@ Notes: [(predicate-implies? (car r*) 'flonum) (values (make-seq ctxt (car e*) false-rec) false-rec t #f #f)] + [(and (not (all-set? (prim-mask unsafe) (primref-flags pr))) + (predicate-implies? (car r*) 'number)) + (let ([pr (primref->unsafe-primref pr)]) + (values `(call ,preinfo ,pr ,e* ...) + ret t #f #f))] [else (values ir ret t #f #f)])] [(and (fx= (length e*) 1) @@ -829,8 +849,22 @@ Notes: [(predicate-implies? (car r*) 'flonum) (values (make-seq ctxt (car e*) true-rec) true-rec t #f #f)] + [(and (not (all-set? (prim-mask unsafe) (primref-flags pr))) + (predicate-implies? (car r*) 'number)) + (let ([pr (primref->unsafe-primref pr)]) + (values `(call ,preinfo ,pr ,e* ...) + ret t #f #f))] [else (values ir ret t #f #f)])] + [(and (not (all-set? (prim-mask unsafe) (primref-flags pr))) + (all-set? (prim-mask safeongoodargs) (primref-flags pr)) + (andmap (lambda (r n) + (predicate-implies? r + (primref->argument-predicate pr n #f))) + r* (enumerate r*))) + (let ([pr (primref->unsafe-primref pr)]) + (values `(call ,preinfo ,pr ,e* ...) + ret types #f #f))] [else (values ir ret t #f #f)])))] [(case-lambda ,preinfo ,cl* ...) diff --git a/s/primdata.ss b/s/primdata.ss index ee2a267a23..00b633e485 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -16,23 +16,23 @@ ;;; r6rs features (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic bitwise)] [flags primitive proc]) - (bitwise-not [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard]) - (bitwise-and [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) - (bitwise-ior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) - (bitwise-xor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) - (bitwise-if [sig [(sint sint sint) -> (sint)]] [flags arith-op mifoldable discard]) - (bitwise-bit-count [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard]) - (bitwise-length [sig [(sint) -> (uint)]] [flags arith-op mifoldable discard]) - (bitwise-first-bit-set [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard]) - (bitwise-bit-set? [sig [(sint uint) -> (boolean)]] [flags pure mifoldable discard]) - (bitwise-copy-bit [sig [(sint uint bit) -> (sint)]] [flags arith-op mifoldable discard]) - (bitwise-bit-field [sig [(sint sub-uint sub-uint) -> (uint)]] [flags arith-op mifoldable discard]) - (bitwise-copy-bit-field [sig [(sint sub-uint sub-uint sint) -> (sint)]] [flags arith-op mifoldable discard]) - (bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03]) - (bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03]) - (bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03]) - (bitwise-rotate-bit-field [sig [(sint sub-uint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard]) - (bitwise-reverse-bit-field [sig [(sint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard]) + (bitwise-not [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) + (bitwise-and [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs]) + (bitwise-ior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs]) + (bitwise-xor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs]) + (bitwise-if [sig [(sint sint sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) + (bitwise-bit-count [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) + (bitwise-length [sig [(sint) -> (uint)]] [flags arith-op mifoldable discard safeongoodargs]) + (bitwise-first-bit-set [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) + (bitwise-bit-set? [sig [(sint uint) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (bitwise-copy-bit [sig [(sint uint bit) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) + (bitwise-bit-field [sig [(sint sub-uint sub-uint) -> (uint)]] [flags arith-op mifoldable discard safeongoodargs]) + (bitwise-copy-bit-field [sig [(sint sub-uint sub-uint sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) + (bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs]) + (bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs]) + (bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs]) + (bitwise-rotate-bit-field [sig [(sint sub-uint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) + (bitwise-reverse-bit-field [sig [(sint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) ) (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic fixnums)] [flags primitive proc]) @@ -40,18 +40,18 @@ (fixnum-width [sig [() -> (fixnum)]] [flags pure unrestricted true cp02]) (least-fixnum [sig [() -> (fixnum)]] [flags pure unrestricted true cp02]) (greatest-fixnum [sig [() -> (fixnum)]] [flags pure unrestricted true cp02]) - (fx (boolean)]] [flags pure cp02]) ; restricted to 2+ arguments - (fx<=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; restricted to 2+ arguments - (fx=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; restricted to 2+ arguments - (fx>? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; restricted to 2+ arguments - (fx>=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; restricted to 2+ arguments - (fxzero? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) - (fxnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) - (fxpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) - (fxeven? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) - (fxodd? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) - (fxmax [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02]) - (fxmin [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02]) + (fx (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments + (fx<=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments + (fx=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments + (fx>? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments + (fx>=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments + (fxzero? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) + (fxnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) + (fxpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) + (fxeven? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) + (fxodd? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) + (fxmax [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02 safeongoodargs]) + (fxmin [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op cp02 safeongoodargs]) ((r6rs: fx*) [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 2 arguments ((r6rs: fx+) [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 2 arguments ((r6rs: fx-) [sig [(fixnum) (fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder]) ; restricted to 1 or 2 arguments @@ -61,17 +61,17 @@ (fxdiv0-and-mod0 [sig [(fixnum fixnum) -> (fixnum fixnum)]] [flags discard]) (fxdiv0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxmod0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02]) - (fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02]) - (fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02]) - (fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) - (fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) - (fxxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) - (fxif [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fxbit-count [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fxlength [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fxfirst-bit-set [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) + (fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02 safeongoodargs]) + (fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02 safeongoodargs]) + (fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02 safeongoodargs]) + (fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs]) + (fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs]) + (fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs]) + (fxxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs]) + (fxif [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs]) + (fxbit-count [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs]) + (fxlength [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs]) + (fxfirst-bit-set [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs]) (fxbit-set? [sig [(fixnum sub-ufixnum) -> (boolean)]] [flags pure cp02]) (fxcopy-bit [sig [(fixnum sub-ufixnum bit) -> (fixnum)]] [flags arith-op cp02]) (fxbit-field [sig [(fixnum sub-ufixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02 cp03]) @@ -90,28 +90,28 @@ (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic flonums)] [flags primitive proc]) (flonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) - (real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard]) - (fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; restricted to 2+ arguments - (fl (boolean)]] [flags pure mifoldable discard]) ; restricted to 2+ arguments - (fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; restricted to 2+ arguments - (fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; restricted to 2+ arguments - (fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; restricted to 2+ arguments - (flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) - (flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) - (flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) - (flnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) + (real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments + (fl (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments + (fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments + (fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments + (fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments + (flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (flnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) (flodd? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) (fleven? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) - (flfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) - (flinfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) - (flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) - (flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard]) - (flmin [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard]) - (fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder]) - (fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder]) - (fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder]) - (fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder]) - (flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) + (flfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (flinfinite? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flmin [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs]) + (fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs]) + (fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs]) + (fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs]) + (flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) (fldiv-and-mod [sig [(flonum flonum) -> (flonum flonum)]] [flags discard]) (fldiv [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flmod [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) @@ -120,25 +120,25 @@ (flmod0 [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (flnumerator [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (fldenominator [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flfloor [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flceiling [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (fltruncate [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flround [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flexp [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (fllog [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flsin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flcos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (fltan [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flasin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flacos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flatan [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flsqrt [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (flexpt [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) + (flfloor [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flceiling [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (fltruncate [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flround [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flexp [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (fllog [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flsin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flcos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (fltan [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flasin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flacos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flatan [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flsqrt [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (flexpt [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) (make-no-infinities-violation [sig [() -> (ptr)]] [flags pure unrestricted alloc]) (no-infinities-violation? [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard]) (make-no-nans-violation [sig [() -> (ptr)]] [flags pure unrestricted alloc]) (no-nans-violation? [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard]) - (fixnum->flonum [sig [(fixnum) -> (flonum)]] [flags arith-op cp02]) + (fixnum->flonum [sig [(fixnum) -> (flonum)]] [flags arith-op cp02 safeongoodargs]) ) (define-symbol-flags* ([libraries (rnrs) (rnrs base) (rnrs exceptions)] [flags keyword]) @@ -192,30 +192,30 @@ (real-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (rational-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (integer-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) - (exact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) - (inexact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) - (inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard]) - (exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard]) - ((r6rs: <) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - ((r6rs: <=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - ((r6rs: =) [sig [(number number number ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - ((r6rs: >) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - ((r6rs: >=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - (zero? [sig [(number) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) - (positive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) - (negative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) - (odd? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) - (even? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) - (finite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard]) - (infinite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard]) - (nan? [sig [(real) -> (boolean)]] [flags pure mifoldable discard]) - (max [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard ieee r5rs]) - (min [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard ieee r5rs]) - (+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs]) - (* [sig [(number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs]) - (- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs]) + (exact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) + (inexact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) + (inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard safeongoodargs]) + (exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard safeongoodargs]) + ((r6rs: <) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: <=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: =) [sig [(number number number ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: >) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: >=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + (zero? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) + (positive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) + (negative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) + (odd? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) + (even? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) + (finite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (infinite? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (nan? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (max [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (min [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs]) + (* [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs]) + (- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs]) (/ [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs]) - (abs [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) + (abs [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) (div-and-mod [sig [(number number) -> (number number)]] [flags discard]) (div [sig [(number number) -> (number)]] [flags arith-op mifoldable discard]) (mod [sig [(number number) -> (number)]] [flags arith-op mifoldable discard]) @@ -226,11 +226,11 @@ (lcm [sig [(number ...) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (numerator [sig [(rational) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs]) (denominator [sig [(rational) -> (integer)]] [flags arith-op mifoldable discard ieee r5rs]) - (floor [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) - (ceiling [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) - (truncate [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) - (round [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) - (rationalize [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) + (floor [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (ceiling [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (truncate [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (round [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (rationalize [sig [(number number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) (exp [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (log [sig [(number) (number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (sin [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) @@ -242,22 +242,22 @@ (sqrt [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (exact-integer-sqrt [sig [(integer) -> (integer integer)]] [flags arith-op mifoldable discard]) (expt [sig [(number number) -> (number)]] [flags pure discard true cp02 ieee r5rs]) ; can take too long to fold - (make-rectangular [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) - (make-polar [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) - (real-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) - (imag-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) - (magnitude [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) - (angle [sig [(number) -> (real)]] [flags arith-op mifoldable discard ieee r5rs]) + (make-rectangular [sig [(number number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (make-polar [sig [(number number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (real-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (imag-part [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (magnitude [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (angle [sig [(number) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) ((r6rs: number->string) [sig [(number) (number sub-ufixnum) (number sub-ufixnum sub-ufixnum) -> (string)]] [flags alloc ieee r5rs]) ; radix restricted to 2, 4, 8, 16 ((r6rs: string->number) [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard ieee r5rs]) ; radix restricted to 2, 4, 8, 16 (not [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs cp02]) (boolean? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) - (boolean=? [sig [(boolean boolean boolean ...) -> (boolean)]] [flags pure mifoldable discard cp03]) + (boolean=? [sig [(boolean boolean boolean ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs]) (pair? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) (cons [sig [(ptr ptr) -> (#1=(ptr . ptr))]] [flags unrestricted alloc ieee r5rs]) ; c..r non-alphabetic so marks come before references - (car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 ieee r5rs]) - (cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 ieee r5rs]) + (car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs]) + (cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs]) (caar [sig [(#2=(#1# . ptr)) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (cdar [sig [(#2#) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (cadr [sig [(#3=(ptr . #1#)) -> (ptr)]] [flags mifoldable discard ieee r5rs]) @@ -297,40 +297,40 @@ (map [sig [(procedure list list ...) -> (list)]] [flags cp02 cp03 ieee r5rs true]) (for-each [sig [(procedure list list ...) -> (ptr ...)]] [flags cp02 cp03 ieee r5rs]) (symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) - (symbol->string [sig [(symbol) -> (string)]] [flags true mifoldable discard ieee r5rs]) - (symbol=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03]) - (string->symbol [sig [(string) -> (symbol)]] [flags true mifoldable discard ieee r5rs]) + (symbol->string [sig [(symbol) -> (string)]] [flags true mifoldable discard safeongoodargs ieee r5rs]) + (symbol=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs]) + (string->symbol [sig [(string) -> (symbol)]] [flags true mifoldable discard safeongoodargs ieee r5rs]) (char? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) - (char->integer [sig [(char) -> (fixnum)]] [flags pure mifoldable discard true ieee r5rs]) + (char->integer [sig [(char) -> (fixnum)]] [flags pure mifoldable discard safeongoodargs true ieee r5rs]) (integer->char [sig [(sub-ufixnum) -> (char)]] [flags pure mifoldable discard true ieee r5rs]) - ((r6rs: char<=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - ((r6rs: char (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - ((r6rs: char=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs cp03]) ; restricted to 2+ arguments - ((r6rs: char>=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - ((r6rs: char>?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: char<=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: char (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: char=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs cp03]) ; restricted to 2+ arguments + ((r6rs: char>=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: char>?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments (string? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) (make-string [sig [(length) (length char) -> (string)]] [flags alloc ieee r5rs]) - (string [sig [(char ...) -> (string)]] [flags alloc ieee r5rs cp02]) - (string-length [sig [(string) -> (length)]] [flags pure true ieee r5rs mifoldable discard]) + (string [sig [(char ...) -> (string)]] [flags alloc ieee r5rs cp02 safeongoodargs]) + (string-length [sig [(string) -> (length)]] [flags pure true ieee r5rs mifoldable discard safeongoodargs]) (string-ref [sig [(string sub-index) -> (ptr)]] [flags true ieee r5rs mifoldable discard cp02]) - ((r6rs: string<=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - ((r6rs: string (boolean)]] [flags mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - ((r6rs: string=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs cp03]) ; restricted to 2+ arguments - ((r6rs: string>=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; restricted to 2+ arguments - ((r6rs: string>?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: string<=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: string (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: string=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs cp03]) ; restricted to 2+ arguments + ((r6rs: string>=?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments + ((r6rs: string>?) [sig [(string string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments (substring [sig [(string sub-length sub-length) -> (string)]] [flags alloc ieee r5rs]) - (string-append [sig [(string ...) -> (string)]] [flags alloc ieee r5rs]) - (string->list [sig [(string) -> (list)]] [flags alloc ieee r5rs]) + (string-append [sig [(string ...) -> (string)]] [flags alloc safeongoodargs ieee r5rs]) + (string->list [sig [(string) -> (list)]] [flags alloc safeongoodargs ieee r5rs]) (list->string [sig [(sub-list) -> (string)]] [flags alloc ieee r5rs]) (string-for-each [sig [(procedure string string ...) -> (void)]] [flags cp03]) - (string-copy [sig [(string) -> (string)]] [flags alloc ieee r5rs]) + (string-copy [sig [(string) -> (string)]] [flags alloc safeongoodargs ieee r5rs]) (vector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) (make-vector [sig [(length) (length ptr) -> (vector)]] [flags alloc ieee r5rs]) (vector [sig [(ptr ...) -> (vector)]] [flags unrestricted alloc ieee r5rs cp02]) - (vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard]) + (vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard safeongoodargs]) (vector-ref [sig [(vector sub-index) -> (ptr)]] [flags ieee r5rs mifoldable discard cp02]) (vector-set! [sig [(vector sub-index ptr) -> (void)]] [flags true ieee r5rs]) - (vector->list [sig [(vector) -> (list)]] [flags alloc ieee r5rs]) + (vector->list [sig [(vector) -> (list)]] [flags alloc safeongoodargs ieee r5rs]) (list->vector [sig [(list) -> (vector)]] [flags alloc ieee r5rs]) (vector-fill! [sig [(vector ptr) -> (void)]] [flags true ieee r5rs]) (vector-map [sig [(procedure vector vector ...) -> (vector)]] [flags cp03]) @@ -353,16 +353,16 @@ (native-endianness [sig [() -> (symbol)]] [flags pure unrestricted alloc cp02]) (bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (make-bytevector [sig [(length) (length u8/s8) -> (bytevector)]] [flags alloc]) - (bytevector-length [sig [(bytevector) -> (length)]] [flags true mifoldable discard]) - (bytevector=? [sig [(bytevector bytevector) -> (boolean)]] [flags mifoldable discard cp03]) + (bytevector-length [sig [(bytevector) -> (length)]] [flags true mifoldable discard safeongoodargs]) + (bytevector=? [sig [(bytevector bytevector) -> (boolean)]] [flags mifoldable discard cp03 safeongoodargs]) (bytevector-fill! [sig [(bytevector u8/s8) -> (void)]] [flags true]) (bytevector-copy! [sig [(bytevector sub-length bytevector sub-length sub-length) -> (void)]] [flags true]) - (bytevector-copy [sig [(bytevector) -> (bytevector)]] [flags alloc]) + (bytevector-copy [sig [(bytevector) -> (bytevector)]] [flags alloc safeongoodargs]) (bytevector-u8-ref [sig [(bytevector sub-index) -> (u8)]] [flags true mifoldable discard]) (bytevector-s8-ref [sig [(bytevector sub-index) -> (s8)]] [flags true mifoldable discard]) (bytevector-u8-set! [sig [(bytevector sub-index u8) -> (void)]] [flags true]) (bytevector-s8-set! [sig [(bytevector sub-index s8) -> (void)]] [flags true]) - (bytevector->u8-list [sig [(bytevector) -> (list)]] [flags alloc]) + (bytevector->u8-list [sig [(bytevector) -> (list)]] [flags alloc safeongoodargs]) (u8-list->bytevector [sig [(sub-list) -> (bytevector)]] [flags alloc]) (bytevector-uint-ref [sig [(bytevector sub-index symbol sub-length) -> (uint)]] [flags true mifoldable discard]) (bytevector-sint-ref [sig [(bytevector sub-index symbol sub-length) -> (sint)]] [flags true mifoldable discard]) @@ -535,9 +535,9 @@ (hashtable-hash-function [sig [(hashtable) -> (ptr)]] [flags]) (hashtable-mutable? [sig [(hashtable) -> (boolean)]] [flags mifoldable discard]) (equal-hash [sig [(ptr) -> (length)]] [flags unrestricted true]) - (string-hash [sig [(string) -> (length)]] [flags true]) - (string-ci-hash [sig [(string) -> (length)]] [flags true]) - (symbol-hash [sig [(symbol) -> (length)]] [flags true]) + (string-hash [sig [(string) -> (length)]] [flags true safeongoodargs]) + (string-ci-hash [sig [(string) -> (length)]] [flags true safeongoodargs]) + (symbol-hash [sig [(symbol) -> (length)]] [flags true safeongoodargs]) ) (define-symbol-flags* ([libraries (rnrs) (rnrs io ports)] [flags keyword]) @@ -729,8 +729,8 @@ ) (define-symbol-flags* ([libraries (rnrs r5rs)] [flags primitive proc]) - (exact->inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard ieee r5rs]) - (inexact->exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard ieee r5rs]) + (exact->inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) + (inexact->exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs]) (quotient [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (remainder [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (modulo [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) @@ -1102,17 +1102,17 @@ ) (define-symbol-flags* ([libraries] [flags primitive proc]) - (< [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (<= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (= [sig [(number number ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (> [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (>= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (-1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) - (1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) - (1- [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) + (< [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (<= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (= [sig [(number number ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (> [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (>= [sig [(real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (-1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs]) + (1+ [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs]) + (1- [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs]) (abort [sig [() (ptr) -> (bottom)]] [flags abort-op]) (acosh [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) - (add1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) + (add1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs]) (andmap [sig [(procedure list list ...) -> (ptr ...)]] [flags cp03]) (annotation? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (annotation-expression [sig [(annotation) -> (ptr)]] [flags pure mifoldable discard true]) @@ -1170,27 +1170,27 @@ (call/1cc [sig [(procedure) -> (ptr ...)]] [flags]) (call-with-input-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument (call-with-output-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument - (cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder]) - (cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder]) - (cfl- [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder]) + (cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs]) + (cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs]) + (cfl- [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs]) (cfl/ [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder]) - (cfl= [sig [(cflonum cflonum ...) -> (boolean)]] [flags pure mifoldable discard]) - (cfl-conjugate [sig [(cflonum) -> (cflonum)]] [flags arith-op mifoldable discard]) - (cfl-imag-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (cfl-magnitude-squared [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard]) - (cfl-real-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard]) + (cfl= [sig [(cflonum cflonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (cfl-conjugate [sig [(cflonum) -> (cflonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (cfl-imag-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (cfl-magnitude-squared [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) + (cfl-real-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) (cflonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) - (char<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (char (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (char=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03]) ; not restricted to 2+ arguments - (char>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (char>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (char- [sig [(char char) -> (fixnum)]] [flags pure mifoldable discard true]) - (char-ci<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (char-ci (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (char-ci=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03]) ; not restricted to 2+ arguments - (char-ci>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (char-ci>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments + (char<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (char (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (char=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs]) ; not restricted to 2+ arguments + (char>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (char>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (char- [sig [(char char) -> (fixnum)]] [flags pure mifoldable discard true safeongoodargs]) + (char-ci<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (char-ci (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (char-ci=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs]) ; not restricted to 2+ arguments + (char-ci>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (char-ci>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments (char-name [sig [(sub-ptr) (sub-symbol maybe-char) -> (ptr)]] [flags]) (char-ready? [sig [() (textual-input-port) -> (boolean)]] [flags ieee r5rs]) (chmod [sig [(pathname sub-ufixnum) -> (void)]] [flags]) @@ -1284,16 +1284,16 @@ (port-file-compressed! [sig [(port) -> (void)]] [flags]) (file-regular? [sig [(pathname) (pathname ptr) -> (boolean)]] [flags discard]) (file-symbolic-link? [sig [(pathname) -> (boolean)]] [flags discard]) - (fllp [sig [(flonum) -> (ufixnum)]] [flags arith-op mifoldable discard]) - (fl-make-rectangular [sig [(flonum flonum) -> (inexactnum)]] [flags arith-op mifoldable discard]) + (fllp [sig [(flonum) -> (ufixnum)]] [flags arith-op mifoldable discard safeongoodargs]) + (fl-make-rectangular [sig [(flonum flonum) -> (inexactnum)]] [flags arith-op mifoldable discard safeongoodargs]) (flonum->fixnum [sig [(flonum) -> (fixnum)]] [flags arith-op cp02]) - (flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) - (flnonnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard]) - (fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments - (fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard]) ; not restricted to 2+ arguments + (flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (flnonnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments (flush-output-port [sig [() (output-port) -> (void)]] [flags true]) ; not restricted to 1 argument (foreign-entry? [sig [(string) -> (boolean)]] [flags discard]) (foreign-entry [sig [(string) -> (uptr)]] [flags discard true]) @@ -1321,39 +1321,39 @@ (fx/ [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 1 or 2 arguments (fx1+ [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fx1- [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fx< [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; not restricted to 2+ arguments - (fx<= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; not restricted to 2+ arguments - (fx= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; not restricted to 2+ arguments - (fx> [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; not restricted to 2+ arguments - (fx>= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02]) ; not restricted to 2+ arguments + (fx< [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; not restricted to 2+ arguments + (fx<= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; not restricted to 2+ arguments + (fx= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; not restricted to 2+ arguments + (fx> [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; not restricted to 2+ arguments + (fx>= [sig [(fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; not restricted to 2+ arguments (fxabs [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxlogand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxlogbit? [sig [(ufixnum fixnum) -> (boolean)]] [flags pure cp02]) (fxlogbit0 [sig [(sub-ufixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxlogbit1 [sig [(sub-ufixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fxlogior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) - (fxlognot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fxlogor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) - (fxlogtest [sig [(fixnum fixnum) -> (boolean)]] [flags pure cp02]) - (fxlogxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) + (fxlogior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs]) + (fxlognot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02 safeongoodargs]) + (fxlogor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs]) + (fxlogtest [sig [(fixnum fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) + (fxlogxor [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs]) (fxmodulo [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fxnonnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) - (fxnonpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02]) + (fxnonnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) + (fxnonpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) (fxquotient [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxremainder [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxsll [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02]) (fxsra [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02]) (fxsrl [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02]) - (fxvector [sig [(fixnum ...) -> (fxvector)]] [flags alloc cp02]) - (fxvector->list [sig [(fxvector) -> (list)]] [flags alloc]) - (fxvector-copy [sig [(fxvector) -> (fxvector)]] [flags alloc]) + (fxvector [sig [(fixnum ...) -> (fxvector)]] [flags alloc cp02 safeongoodargs]) + (fxvector->list [sig [(fxvector) -> (list)]] [flags alloc safeongoodargs]) + (fxvector-copy [sig [(fxvector) -> (fxvector)]] [flags alloc safeongoodargs]) (fxvector-fill! [sig [(fxvector fixnum) -> (void)]] [flags true]) - (fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc]) - (fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true]) + (fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc safeongoodargs]) + (fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true safeongoodargs]) (fxvector-ref [sig [(fxvector sub-index) -> (fixnum)]] [flags mifoldable discard cp02]) (fxvector-set! [sig [(fxvector sub-index fixnum) -> (void)]] [flags true]) (fxvector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) - (gensym [sig [() (string) (string string) -> (gensym)]] [flags alloc]) + (gensym [sig [() (string) (string string) -> (gensym)]] [flags alloc safeongoodargs]) (gensym? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (gensym->unique-string [sig [(gensym) -> (string)]] [flags true mifoldable]) ; can't discard ... if we have our hands on it, it must be in the oblist after this (get-bytevector-some! [sig [(binary-input-port bytevector length length) -> (ptr)]] [flags true]) @@ -1405,15 +1405,15 @@ (lock-object [sig [(ptr) -> (void)]] [flags unrestricted true]) (locked-object? [sig [(ptr) -> (boolean)]] [flags unrestricted discard]) (logand [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) - (logbit? [sig [(uint sint) -> (boolean)]] [flags pure mifoldable discard]) + (logbit? [sig [(uint sint) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) (logbit0 [sig [(uint sint) -> (sint)]] [flags arith-op mifoldable discard]) (logbit1 [sig [(uint sint) -> (sint)]] [flags arith-op mifoldable discard]) - (logior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) - (lognot [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard]) - (logor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) - (logtest [sig [(sint sint) -> (boolean)]] [flags pure mifoldable discard]) - (logxor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder]) - (magnitude-squared [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) + (logior [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs]) + (lognot [sig [(sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs]) + (logor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs]) + (logtest [sig [(sint sint) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) + (logxor [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs]) + (magnitude-squared [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs]) (make-annotation [sig [(ptr source-object ptr) (ptr source-object ptr annotation-options) -> (annotation)]] [flags pure true mifoldable discard]) (make-boot-file [sig [(pathname sub-list pathname ...) -> (void)]] [flags true]) (make-boot-header [sig [(pathname pathname pathname ...) -> (void)]] [flags true]) @@ -1509,7 +1509,7 @@ (pretty-format [sig [(symbol) -> (ptr)] [(symbol sub-ptr) -> (void)]] [flags]) (pretty-print [sig [(ptr) (ptr textual-output-port) -> (void)]] [flags true]) (printf [sig [(string sub-ptr ...) -> (void)]] [flags true]) - (procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard true]) + (procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard safeongoodargs true]) (process [sig [(string) -> (list)]] [flags]) (profile-clear-database [sig [() -> (void)]] [flags true]) (profile-clear [sig [() -> (void)]] [flags true]) @@ -1517,12 +1517,12 @@ (profile-dump-data [sig [(pathname) (pathname sub-list) -> (void)]] [flags true]) (profile-dump-list [sig [() (ptr) (ptr sub-list) -> (list)]] [flags discard true]) (profile-dump-html [sig [() (pathname) (pathname sub-list) -> (void)]] [flags true]) - (property-list [sig [(symbol) -> (list)]] [flags discard true]) + (property-list [sig [(symbol) -> (list)]] [flags discard true safeongoodargs]) (put-bytevector-some [sig [(binary-output-port bytevector) (binary-output-port bytevector length) (binary-output-port bytevector length length) -> (uint)]] [flags true]) (put-hash-table! [sig [(old-hash-table ptr ptr) -> (void)]] [flags true]) (put-registry! [feature windows] [sig [(string string) -> (void)]] [flags true]) (put-string-some [sig [(textual-output-port string) (textual-output-port string length) (textual-output-port string length length) -> (uint)]] [flags true]) - (putprop [sig [(symbol ptr ptr) -> (void)]] [flags true]) + (putprop [sig [(symbol ptr ptr) -> (void)]] [flags true safeongoodargs]) (putenv [sig [(string string) -> (void)]] [flags true]) (profile-query-weight [sig [(ptr) -> (maybe-flonum)]] [flags unrestricted discard]) (random [sig [(sub-number) -> (number)]] [flags alloc]) @@ -1543,7 +1543,7 @@ (remove-hash-table! [sig [(old-hash-table ptr) -> (void)]] [flags true]) (remove-registry! [feature windows] [sig [(string) -> (void)]] [flags true]) (remove! [sig [(ptr list) -> (list)]] [flags true]) - (remprop [sig [(symbol ptr) -> (void)]] [flags]) + (remprop [sig [(symbol ptr) -> (void)]] [flags safeongoodargs]) (remq! [sig [(ptr list) -> (list)]] [flags true]) (remv! [sig [(ptr list) -> (list)]] [flags true]) (rename-file [sig [(pathname ptr) -> (void)]] [flags]) @@ -1621,21 +1621,21 @@ (statistics [sig [() -> (sstats)]] [flags unrestricted alloc]) (string->multibyte [feature windows] [sig [(sub-uint string) -> (bytevector)]] [flags true discard]) (string->number [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard]) ; radix not restricted to 2, 4, 8, 16 - (string<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard]) ; not restricted to 2+ arguments - (string (boolean)]] [flags mifoldable discard]) ; not restricted to 2+ arguments - (string=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard cp03]) ; not restricted to 2+ arguments - (string>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard]) ; not restricted to 2+ arguments - (string>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard]) ; not restricted to 2+ arguments - (string-ci<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; not restricted to 2+ arguments - (string-ci (boolean)]] [flags mifoldable discard ieee r5rs]) ; not restricted to 2+ arguments - (string-ci=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs cp03]) ; not restricted to 2+ arguments - (string-ci>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; not restricted to 2+ arguments - (string-ci>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard ieee r5rs]) ; not restricted to 2+ arguments + (string<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (string (boolean)]] [flags mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (string=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard cp03 safeongoodargs]) ; not restricted to 2+ arguments + (string>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (string>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments + (string-ci<=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; not restricted to 2+ arguments + (string-ci (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; not restricted to 2+ arguments + (string-ci=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs cp03]) ; not restricted to 2+ arguments + (string-ci>=? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; not restricted to 2+ arguments + (string-ci>? [sig [(string string ...) -> (boolean)]] [flags mifoldable discard safeongoodargs ieee r5rs]) ; not restricted to 2+ arguments (string-copy! [sig [(string sub-length string sub-length sub-length) -> (void)]] [flags true]) - (string->immutable-string [sig [(string) -> (string)]] [flags alloc]) + (string->immutable-string [sig [(string) -> (string)]] [flags alloc safeongoodargs]) (string-truncate! [sig [(string length) -> (string)]] [flags true]) (strip-fasl-file [sig [(pathname pathname fasl-strip-options) -> (void)]] [flags true]) - (sub1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) + (sub1 [sig [(number) -> (number)]] [flags arith-op mifoldable discard safeongoodargs]) (subst [sig [(ptr ptr ptr) -> (ptr)]] [flags alloc]) (subst! [sig [(ptr ptr ptr) -> (ptr)]] [flags]) (substq [sig [(ptr ptr ptr) -> (ptr)]] [flags alloc]) @@ -1678,7 +1678,7 @@ (transcript-on [sig [(pathname) -> (void)]] [flags true ieee r5rs]) (truncate-file [sig [(output-port) (output-port sub-ptr) -> (void)]] [flags]) (truncate-port [sig [(output-port) (output-port sub-ptr) -> (void)]] [flags]) - (unbox [sig [(box) -> (ptr)]] [flags mifoldable discard]) + (unbox [sig [(box) -> (ptr)]] [flags mifoldable discard safeongoodargs]) (unget-u8 [sig [(binary-input-port ptr) -> (void)]] [flags true]) (unget-char [sig [(textual-input-port ptr) -> (void)]] [flags true]) (unlock-object [sig [(ptr) -> (void)]] [flags unrestricted true]) @@ -1686,8 +1686,8 @@ (utf-16-codec [sig [() -> (codec)] [(sub-symbol) -> (codec)]] [flags pure true]) ; has optional eness argument (utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true]) (utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true]) - (vector-copy [sig [(vector) -> (vector)]] [flags alloc]) - (vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc]) + (vector-copy [sig [(vector) -> (vector)]] [flags alloc safeongoodargs]) + (vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc safeongoodargs]) (vector-set-fixnum! [sig [(vector sub-index fixnum) -> (void)]] [flags true]) (virtual-register [sig [(sub-index) -> (ptr)]] [flags discard]) (virtual-register-count [sig [() -> (length)]] [flags pure unrestricted true cp02]) From 18b12f21fd21b9cd44220813a113885f1edd4b04 Mon Sep 17 00:00:00 2001 From: Andy Keep Date: Tue, 3 Apr 2018 20:22:25 -0400 Subject: [PATCH 07/11] Fixes and small improvements for type recovery. Removed counter field from prelex, using the operand field instead to provide the index into the fxmap. This follows other uses within the compiler where we use the operand field as a little place for state that is used within a single pass. This has a few advantages. First, it keeps the record a little smaller. Second, it means that the prelex numbering can start from 0 for each compilation unit, which should help keep the numbers for the fxmap a bit smaller in longer running sessions with multiple calls to the compiler. Finally, it avoids adding to the burden of the tc-mutex, since within the pass it is safe for us to set the prelexes, since only the instance of the pass holding this block of code has a handle on it. As part of this change prelex-counter is now defined in cptypes and the operand is cleared after the variables go out of scope. base-lang.ss Fixed the highest-set-bit function in fxmap so that it will work in the 32-bit versions of Chez Scheme. The fxsrl by 32 raises an exception, and was leading to tests to fail in 32-bit mode. fxmap.ss Restructured predicate-implies? so that it uses committed choice instead of uncommitted choice in comparing x and y. Basically, this means, instead of doing: (or (and (predicate-1? x) (predicate-1? y) ---) (and (predicate-2? x) (predicate-2? y) ---) ...) we now do: (cond [(predicate-1? x) (and (predicate-1? y) ---)] [(predicate-2? x) (and (predicate-2? y) ---)] ...) This avoids running predicates on x that we know will fail because an earlier predicate matches, generally getting out of the predicate faster. This did require a little restructuring, because in some cases x was dominant and in other cases y was dominant. This is now restructured with y dominate, after the eq? and x 'bottom check. Replaced let-values calls with cata-morphism syntax, including removal of maps that built up a list of values that then needed to be separated out with (map car ...) (map cadr ...) etc. calls. This avoid building up structures we don't need, since the nanopass framework will generate a mutltivalued let for these situations. The if clause in cptypes/raw now uses types1 (the result of the recursive call on e1) in place of the incoming types clause when processing the e2 or e3 expressions in the cases where e1 is known statically to produce either a false or non-false value. Fixed a bug with directly-applied variable arity lambda. The original code marked all directly-applied variable arity lambda's as producing bottom, because it was chacking for the interface to be equal to the number of arguments. However, variable arity functions are represented with a negative number. For instance, the original code would transform the expression: (begin ((lambda (a . b) (set! t (cons* b a t))) 'a 'b 'c) t) to ((lambda (a . b) (set! t (cons* b a t))) 'a 'b 'c) anticipating that the call would raise an error, however, it is a perfectly valid (if some what unusual) expression. I tried to come up with a test for this, however, without building something fairly complicated, it is difficult to get past cp0 without cp0 turning it into something like: (let ([b (list 'b 'c)]) (set! t (cons* b 'a t)) t) Fixed make-time, time-second-set!, and time-second to indicate that second can be an exact-integer, since it is not really restricted to the fixnum range (and if fact we even test this fact in the mats on 32-bit machines). primdata.ss Changed check of prelex-was-assigned (which is not reliably on the input to any give pass) with prelex-assigned, which should always have an accurate, if conservative, value in it. Added enable-type-recovery parameter to allow the type recover to be turned on and off, and added cptype to the cp0 not run path that runs cpletrec, so that cptypes can be run independent of cp0. This is helpful for testing and allows us to benefit from type recovery, even in cases where we do not want cp0 to perform any inlining. compile.ss, front.ss, primdata.ss Stylistic changes, mostly for consistency with other parts of the compiler, though I'm not married to these changes if you'd really prefer to keep things the way the are. 1. clauses of define-record type now use parenthesis instead of square brackets. 2. indented by 2 spaces where things were only indented by one space 3. define, let, define-pass, nanopass pass productions clauses, now use parenthesis for outer markers instead of square brackets. fxmap.ss, original commit: 5c6c5a534ff708d4bff23f6fd48fe6726a5c4e05 --- mats/cptypes.ms | 83 +++++++ s/base-lang.ss | 21 +- s/compile.ss | 23 +- s/cpnanopass.ss | 1 + s/cptypes.ss | 572 +++++++++++++++++++++++------------------------- s/front.ss | 2 + s/fxmap.ss | 48 ++-- s/primdata.ss | 7 +- 8 files changed, 412 insertions(+), 345 deletions(-) diff --git a/mats/cptypes.ms b/mats/cptypes.ms index f7fa5512e5..0433672f35 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -314,6 +314,89 @@ (if (if y #f z) (f t 1) (f t 2)))))) ) +(mat cptype-directly-applied-case-lambda + (equal? + (parameterize ([enable-type-recovery #t] + [run-cp0 (lambda (cp0 x) x)]) + (eval + '(let ([t ((lambda (x y) (cons y x)) 'a 'b)]) + (list t t)))) + '((b . a) (b . a))) + (equal? + (parameterize ([enable-type-recovery #t] + [run-cp0 (lambda (cp0 x) x)]) + (eval + '(let ([t ((lambda (x . y) (cons y x)) 'a 'b 'c 'd)]) + (list t t)))) + '(((b c d) . a) ((b c d) . a))) + (equal? + (parameterize ([enable-type-recovery #t] + [run-cp0 (lambda (cp0 x) x)]) + (eval + '(let ([t ((case-lambda + [(x) (cons 'first x)] + [(x y) (cons* 'second y x)] + [(x . y) (cons* 'third y x)]) 'a 'b)]) + (list t t)))) + '((second b . a) (second b . a))) + (equal? + (parameterize ([enable-type-recovery #t] + [run-cp0 (lambda (cp0 x) x)]) + (eval + '(let ([t ((case-lambda + [(x) (cons 'first x)] + [(x y) (cons* 'second y x)] + [(x . y) (cons* 'third y x)]) 'a 'b 'c)]) + (list t t)))) + '((third (b c) . a) (third (b c) . a))) + (equal? + (parameterize ([enable-type-recovery #t] + [run-cp0 (lambda (cp0 x) x)]) + (eval + '(let ([t 'z]) + ((lambda args (set! t (cons args t))) 'a 'b 'c) + t))) + '((a b c) . z)) + (equal? + (parameterize ([enable-type-recovery #t] + [run-cp0 (lambda (cp0 x) x)]) + (eval + '(let ([t 'z]) + ((lambda args (set! t (cons args t))) 'a 'b 'c) + t))) + '((a b c) . z)) + (equal? + (parameterize ([enable-type-recovery #t] + [run-cp0 (lambda (cp0 x) x)]) + (eval + '(let ([t 'z]) + ((lambda (x . y) (set! t (cons* y x t))) 'a 'b 'c) + t))) + '((b c) a . z)) + (equal? + (parameterize ([enable-type-recovery #t] + [run-cp0 (lambda (cp0 x) x)]) + (eval + '(let ([t 'z]) + ((case-lambda + [(x) (set! t (cons* 'first x t))] + [(x y) (set! t (cons* 'second y x t))] + [(x . y) (set! t (cons* 'third y x t))]) 'a 'b) + t))) + '(second b a . z)) + (equal? + (parameterize ([enable-type-recovery #t] + [run-cp0 (lambda (cp0 x) x)]) + (eval + '(let ([t 'z]) + ((case-lambda + [(x) (set! t (cons* 'first x t))] + [(x y) (set! t (cons* 'second y x t))] + [(x . y) (set! t (cons* 'third y x t))]) 'a 'b 'c 'd) + t))) + '(third (b c d) a . z)) +) + (define (test-chain/preamble/self preamble check-self? l) (let loop ([l l]) (if (null? l) diff --git a/s/base-lang.ss b/s/base-lang.ss index 9f1d829966..a615ddc2ad 100644 --- a/s/base-lang.ss +++ b/s/base-lang.ss @@ -18,7 +18,7 @@ sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags preinfo-lambda-libspec prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set! - prelex-source prelex-operand prelex-operand-set! prelex-uname prelex-counter make-prelex* + prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex* target-fixnum? target-bignum?) (module (lookup-primref primref? primref-name primref-flags primref-arity primref-signatures primref-level) @@ -78,16 +78,15 @@ prelex-flags prelex-flags-set! prelex-source prelex-operand prelex-operand-set! - prelex-uname - prelex-counter) + prelex-uname) (define-record-type prelex - (nongenerative #{prelex grpmhtzqa9bflxfggfu6pp-1}) + (nongenerative #{prelex grpmhtzqa9bflxfggfu6pp-2}) (sealed #t) - (fields (mutable name) (mutable flags) source (mutable operand) (mutable $uname) (mutable $counter)) + (fields (mutable name) (mutable flags) source (mutable operand) (mutable $uname)) (protocol (lambda (new) (lambda (name flags source operand) - (new name flags source operand #f #f))))) + (new name flags source operand #f))))) (define prelex-uname (lambda (id) (or (prelex-$uname id) @@ -95,16 +94,6 @@ (with-tc-mutex (or (prelex-$uname id) (begin (prelex-$uname-set! id uname) uname))))))) - (define counter 0) - (define prelex-counter - (lambda (id) - (or (prelex-$counter id) - (with-tc-mutex - (or (prelex-$counter id) - (let ([c counter]) - (set! counter (fx1+ counter)) - (prelex-$counter-set! id c) - c)))))) (record-writer (record-type-descriptor prelex) (lambda (x p wr) (fprintf p "~s" (prelex-name x))))) diff --git a/s/compile.ss b/s/compile.ss index fb017f76af..2b09109688 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -550,6 +550,12 @@ (when ($enable-check-prelex-flags) ($pass-time 'cpcheck-prelex-flags (lambda () (do-trace $cpcheck-prelex-flags x 'uncprep)))))) +(define cptypes + (lambda (x) + (if (enable-type-recovery) + ($pass-time 'cptypes (lambda () ($cptypes x))) + x))) + (define compile-file-help (lambda (op hostop wpoop machine sfd do-read outfn) (include "types.ss") @@ -567,7 +573,8 @@ [$compile-profile ($compile-profile)] [generate-interrupt-trap (generate-interrupt-trap)] [$optimize-closures ($optimize-closures)] - [enable-cross-library-optimization (enable-cross-library-optimization)]) + [enable-cross-library-optimization (enable-cross-library-optimization)] + [enable-type-recovery (enable-type-recovery)]) (emit-header op (constant machine-type)) (when hostop (emit-header hostop (host-machine-type))) (when wpoop (emit-header wpoop (host-machine-type))) @@ -647,7 +654,7 @@ (set! cpletrec-ran? #t) (let* ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))] [waste (check-prelex-flags x 'cp0)] - [x ($pass-time 'cptypes (lambda () (do-trace $cptypes x)))] + [x (cptypes x)] [waste (check-prelex-flags x 'cptypes)] [x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))] [waste (check-prelex-flags x 'cpletrec)]) @@ -655,8 +662,10 @@ x2)]) (if cpletrec-ran? x - (let ([x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]) - (check-prelex-flags x 'cpletrec) + (let* ([x (cptypes x)] + [waste (check-prelex-flags x 'cptypes)] + [x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))] + [waste (check-prelex-flags x 'cpletrec)]) x))))] [x2b ($pass-time 'cpcheck (lambda () (do-trace $cpcheck x2a)))] [waste (check-prelex-flags x2b 'cpcheck)] @@ -1472,10 +1481,12 @@ (lambda (x) (set! cpletrec-ran? #t) (let* ([x ($pass-time 'cp0 (lambda () ($cp0 x)))] - [x ($pass-time 'cptypes (lambda () ($cptypes x)))]) + [x (cptypes x)]) ($pass-time 'cpletrec (lambda () ($cpletrec x))))) x2)]) - (if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))] + (if cpletrec-ran? x + (let ([x (cptypes x)]) + ($pass-time 'cpletrec (lambda () ($cpletrec x)))))))] [x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))] [x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))]) (when (and (expand/optimize-output) (not ($noexpand? x0))) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 2ae10538e4..4f86e73dc3 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -4361,6 +4361,7 @@ [(e1 e2) (dofxlogbit1 e2 e1)]) (define-inline 3 fxcopy-bit [(e1 e2 e3) + ;; NB: even in the case where e3 is not known to be 0 or 1, seems like we could do better here. (and (fixnum-constant? e3) (case (constant-value e3) [(0) (dofxlogbit0 e1 e2)] diff --git a/s/cptypes.ss b/s/cptypes.ss index 0cb073690c..d2735a84e4 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -61,12 +61,22 @@ Notes: |# -[define $cptypes -[let () +(define $cptypes +(let () (import (nanopass)) (include "base-lang.ss") (include "fxmap.ss") + (define prelex-counter + (let () + (define count 0) + (lambda (x) + (or (prelex-operand x) + (let ([c count]) + (set! count (fx+ count 1)) + (prelex-operand-set! x c) + c))))) + (with-output-language (Lsrc Expr) (define void-rec `(quote ,(void))) (define true-rec `(quote #t)) @@ -141,7 +151,7 @@ Notes: (define (pred-env-add types x pred) (cond - [(and x (not (prelex-was-assigned x))) + [(and x (not (prelex-assigned x))) (pred-env-add/key types (prelex-counter x) pred)] [else types])) @@ -149,7 +159,7 @@ Notes: (fxmap-remove/base types (prelex-counter x) base)) (define (pred-env-lookup types x) - (and (not (prelex-was-assigned x)) + (and (not (prelex-assigned x)) (fxmap-ref types (prelex-counter x) #f))) ; This is conceptually the intersection of the types in `types` and `from` @@ -166,13 +176,13 @@ Notes: [else (let ([ret types]) (fxmap-for-each/diff (lambda (key x y) - (let ([z (fxmap-ref types key #f)]) - ;x-> from - ;y-> base - ;z-> types - (set! ret (pred-env-add/key ret key (pred-intersect x z))))) + (let ([z (fxmap-ref types key #f)]) + ;x-> from + ;y-> base + ;z-> types + (set! ret (pred-env-add/key ret key (pred-intersect x z))))) (lambda (key x) - (set! ret (pred-env-add/key ret key x))) + (set! ret (pred-env-add/key ret key x))) (lambda (key x) (error 'pred-env-intersect/base "") (void)) from base) @@ -252,20 +262,20 @@ Notes: (define (pred-env-rebase types base new-base) (let ([ret types]) (fxmap-for-each/diff (lambda (key x y) - (let ([z (fxmap-ref types key #f)]) - ;x-> new-base - ;y-> base - ;z-> types - (if (eq? x z) - (set! ret (fxmap-reset/base ret key new-base)) - (set! ret (fxmap-advance/base ret key new-base))))) + (let ([z (fxmap-ref types key #f)]) + ;x-> new-base + ;y-> base + ;z-> types + (if (eq? x z) + (set! ret (fxmap-reset/base ret key new-base)) + (set! ret (fxmap-advance/base ret key new-base))))) (lambda (key x) - (let ([z (fxmap-ref types key #f)]) - ;x-> new-base - ;z-> types - (if (eq? x z) - (set! ret (fxmap-reset/base ret key new-base)) - (set! ret (fxmap-advance/base ret key new-base))))) + (let ([z (fxmap-ref types key #f)]) + ;x-> new-base + ;z-> types + (if (eq? x z) + (set! ret (fxmap-reset/base ret key new-base)) + (set! ret (fxmap-advance/base ret key new-base))))) (lambda (key x) (error 'pred-env-rebase "") (void)) new-base base) @@ -329,7 +339,7 @@ Notes: (guard (record-type-descriptor? d)) (list '$record/rtd d)] [(ref ,maybe-src ,x) - (guard (not (prelex-was-assigned x))) + (guard (not (prelex-assigned x))) (list '$record/ref x)] [(record-type ,rtd ,e) (rtd->record-predicate e)] @@ -432,63 +442,69 @@ Notes: (and x y (or (eq? x y) - (and (Lsrc? x) - (Lsrc? y) - (nanopass-case (Lsrc Expr) x - [(quote ,d1) - (nanopass-case (Lsrc Expr) y - [(quote ,d2) (eqv? d1 d2)] #;CHECK ;eq?/eqv?/equal? - [else #f])] - [else #f])) - (and (pair? x) (pair? (cdr x)) (eq? (car x) '$record/rtd) - (pair? y) (pair? (cdr y)) (eq? (car y) '$record/rtd) - (cond - [(record-type-sealed? (cadr y)) - (eqv? (cadr x) (cadr y))] - [else - (let loop ([x (cadr x)] [y (cadr y)]) - (or (eqv? x y) - (let ([xp (record-type-parent x)]) - (and xp (loop xp y)))))])) - (and (pair? x) (pair? (cdr x)) (eq? (car x) '$record/ref) - (pair? y) (pair? (cdr y)) (eq? (car y) '$record/ref) - (eq? (cadr x) (cadr y))) (eq? x 'bottom) - (case y - [(null-or-pair) (or (check-constant-is? x null?) - (eq? x 'pair))] - [(fixnum) (check-constant-is? x target-fixnum?)] - [(exact-integer) - (or (eq? x 'fixnum) - (check-constant-is? x (lambda (x) (and (integer? x) - (exact? x)))))] - [(flonum) (check-constant-is? x flonum?)] - [(real) (or (eq? x 'fixnum) - (eq? x 'exact-integer) - (eq? x 'flonum) - (check-constant-is? x real?))] - [(number) (or (eq? x 'fixnum) - (eq? x 'exact-integer) - (eq? x 'flonum) - (eq? x 'real) - (check-constant-is? x number?))] - [(gensym) (check-constant-is? x gensym?)] - [(symbol) (or (eq? x 'gensym) - (check-constant-is? x symbol?))] - [(char) (check-constant-is? x char?)] - [(boolean) (or (check-constant-is? x not) - (check-constant-is? x (lambda (x) (eq? x #t))))] - [(true) (and (not (check-constant-is? x not)) - (not (eq? x 'boolean)) - (not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f - [($record) (or (check-constant-is? x #3%$record?) - (and (pair? x) (eq? (car x) '$record/rtd)) - (and (pair? x) (eq? (car x) '$record/ref)))] - [(vector) (check-constant-is? x vector?)] ; i.e. '#() - [(string) (check-constant-is? x string?)] ; i.e. "" - [(bytevector) (check-constant-is? x bytevector?)] ; i.e. '#vu8() - [(fxvector) (check-constant-is? x fxvector?)] ; i.e. '#vfx() - [(ptr) #t] + (cond + [(Lsrc? y) + (and (Lsrc? x) + (nanopass-case (Lsrc Expr) y + [(quote ,d1) + (nanopass-case (Lsrc Expr) x + [(quote ,d2) (eqv? d1 d2)] #;CHECK ;eq?/eqv?/equal? + [else #f])] + [else #f]))] + [(and (pair? y) (pair? (cdr y))) + (and (pair? x) (pair? (cdr x)) + (cond + [(eq? (car y) '$record/rtd) + (and (eq? (car x) '$record/rtd) + (let ([y-rtd (cadr y)]) + (cond + [(record-type-sealed? y-rtd) + (eqv? (cadr x) y-rtd)] + [else + (let loop ([x-rtd (cadr x)]) + (or (eqv? x-rtd y-rtd) + (let ([xp (record-type-parent x-rtd)]) + (and xp (loop xp)))))])))] + [(eq? (car y) '$record/ref) + (and (eq? (car x) '$record/ref) + (eq? (cadr x) (cadr y)))] + [else #f]))] + [(case y + [(null-or-pair) (or (eq? x 'pair) + (check-constant-is? x null?))] + [(fixnum) (check-constant-is? x target-fixnum?)] + [(exact-integer) + (or (eq? x 'fixnum) + (check-constant-is? x (lambda (x) (and (integer? x) + (exact? x)))))] + [(flonum) (check-constant-is? x flonum?)] + [(real) (or (eq? x 'fixnum) + (eq? x 'exact-integer) + (eq? x 'flonum) + (check-constant-is? x real?))] + [(number) (or (eq? x 'fixnum) + (eq? x 'exact-integer) + (eq? x 'flonum) + (eq? x 'real) + (check-constant-is? x number?))] + [(gensym) (check-constant-is? x gensym?)] + [(symbol) (or (eq? x 'gensym) + (check-constant-is? x symbol?))] + [(char) (check-constant-is? x char?)] + [(boolean) (check-constant-is? x boolean?)] + [(true) (and (not (check-constant-is? x not)) + (not (eq? x 'boolean)) + (not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f + [($record) (or (and (pair? x) (eq? (car x) '$record/rtd)) + (and (pair? x) (eq? (car x) '$record/ref)) + (check-constant-is? x #3%$record?))] + [(vector) (check-constant-is? x vector?)] ; i.e. '#() + [(string) (check-constant-is? x string?)] ; i.e. "" + [(bytevector) (check-constant-is? x bytevector?)] ; i.e. '#vu8() + [(fxvector) (check-constant-is? x fxvector?)] ; i.e. '#vfx() + [(ptr) #t] + [else #f])] [else #f])))) (define (predicate-implies-not? x y) @@ -600,8 +616,8 @@ Notes: (define (primref->unsafe-primref pr) (lookup-primref 3 (primref-name pr))) - [define-pass cptypes/raw : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types) - [Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types) + (define-pass cptypes/raw : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types) + (Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types) [(quote ,d) (values ir (datum->predicate d ir) #f #f #f)] [(ref ,maybe-src ,x) @@ -629,101 +645,89 @@ Notes: (values ir t #f #f #f)])] [else (values ir t #f #f #f)]))])] - [(seq ,e1 ,e2) - (let-values ([(e1 ret1 types t-types f-types) - (cptypes e1 'effect types)]) - (cond - [(predicate-implies? ret1 'bottom) - (values e1 ret1 types #f #f)] - [else - (let-values ([(e2 ret types t-types f-types) - (cptypes e2 ctxt types)]) - (values (make-seq ctxt e1 e2) ret types t-types f-types))]))] - [(if ,e1 ,e2 ,e3) - (let-values ([(e1 ret1 types1 t-types1 f-types1) - (cptypes e1 'test types)]) - (cond - [(predicate-implies? ret1 'bottom) ;check bottom first - (values e1 ret1 types #f #f)] - [(predicate-implies-not? ret1 false-rec) - (let-values ([(e2 ret types t-types f-types) - (cptypes e2 ctxt types)]) - (values (make-seq ctxt e1 e2) ret types t-types f-types))] - [(predicate-implies? ret1 false-rec) - (let-values ([(e3 ret types t-types f-types) - (cptypes e3 ctxt types)]) - (values (make-seq ctxt e1 e3) ret types t-types f-types))] - [else - (let-values ([(e2 ret2 types2 t-types2 f-types2) - (cptypes e2 ctxt t-types1)] - [(e3 ret3 types3 t-types3 f-types3) - (cptypes e3 ctxt f-types1)]) - (let ([ir `(if ,e1 ,e2 ,e3)]) - (cond - [(predicate-implies? ret2 'bottom) ;check bottom first - (values ir ret3 types3 t-types3 f-types3)] - [(predicate-implies? ret3 'bottom) ;check bottom first - (values ir ret2 types2 t-types2 f-types2)] - [else - (let ([new-types (pred-env-union/super-base types2 t-types1 - types3 f-types1 - types1 - types1)]) - (values ir - (cond - [(and (eq? ctxt 'test) - (predicate-implies-not? ret2 false-rec) - (predicate-implies-not? ret3 false-rec)) - true-rec] - [else - (pred-union ret2 ret3)]) - new-types - (cond - [(not (eq? ctxt 'test)) - #f] ; don't calculate t-types outside a test context - [(predicate-implies? ret2 false-rec) - (pred-env-rebase t-types3 types1 new-types)] - [(predicate-implies? ret3 false-rec) - (pred-env-rebase t-types2 types1 new-types)] - [(and (eq? types2 t-types2) - (eq? types3 t-types3)) - #f] ; don't calculate t-types when it will be equal to new-types - [else - (pred-env-union/super-base t-types2 t-types1 - t-types3 f-types1 - types1 - new-types)]) - (cond - [(not (eq? ctxt 'test)) - #f] ; don't calculate f-types outside a test context - [(predicate-implies-not? ret2 false-rec) - (pred-env-rebase f-types3 types1 new-types)] - [(predicate-implies-not? ret3 false-rec) - (pred-env-rebase f-types2 types1 new-types)] - [(and (eq? types2 f-types2) - (eq? types3 f-types3)) - #f] ; don't calculate t-types when it will be equal to new-types - [else - (pred-env-union/super-base f-types2 t-types1 - f-types3 f-types1 - types1 - new-types)])))])))]))] - [(set! ,maybe-src ,x ,e) - (let-values ([(e ret types t-types f-types) - (cptypes e 'value types)]) - (values `(set! ,maybe-src ,x ,e) - void-rec types #f #f))] - [(call ,preinfo ,pr ,e* ...) - (let* ([e/r/t* (map (lambda (e) - (let-values ([(e r t t-t f-t) - (cptypes e 'value types)]) - (list e r t))) - e*)] - [e* (map car e/r/t*)] - [r* (map cadr e/r/t*)] - [t* (map caddr e/r/t*)] - [t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] + [(seq ,[cptypes : e1 'effect types -> e1 ret1 types t-types f-types] ,e2) + (cond + [(predicate-implies? ret1 'bottom) + (values e1 ret1 types #f #f)] + [else + (let-values ([(e2 ret types t-types f-types) + (cptypes e2 ctxt types)]) + (values (make-seq ctxt e1 e2) ret types t-types f-types))])] + [(if ,[cptypes : e1 'test types -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3) + (cond + [(predicate-implies? ret1 'bottom) ;check bottom first + (values e1 ret1 types #f #f)] + [(predicate-implies-not? ret1 false-rec) + (let-values ([(e2 ret types t-types f-types) + (cptypes e2 ctxt types1)]) + (values (make-seq ctxt e1 e2) ret types t-types f-types))] + [(predicate-implies? ret1 false-rec) + (let-values ([(e3 ret types t-types f-types) + (cptypes e3 ctxt types1)]) + (values (make-seq ctxt e1 e3) ret types t-types f-types))] + [else + (let-values ([(e2 ret2 types2 t-types2 f-types2) + (cptypes e2 ctxt t-types1)] + [(e3 ret3 types3 t-types3 f-types3) + (cptypes e3 ctxt f-types1)]) + (let ([ir `(if ,e1 ,e2 ,e3)]) + (cond + [(predicate-implies? ret2 'bottom) ;check bottom first + (values ir ret3 types3 t-types3 f-types3)] + [(predicate-implies? ret3 'bottom) ;check bottom first + (values ir ret2 types2 t-types2 f-types2)] + [else + (let ([new-types (pred-env-union/super-base types2 t-types1 + types3 f-types1 + types1 + types1)]) + (values ir + (cond + [(and (eq? ctxt 'test) + (predicate-implies-not? ret2 false-rec) + (predicate-implies-not? ret3 false-rec)) + true-rec] + [else + (pred-union ret2 ret3)]) + new-types + (cond + [(not (eq? ctxt 'test)) + #f] ; don't calculate t-types outside a test context + [(predicate-implies? ret2 false-rec) + (pred-env-rebase t-types3 types1 new-types)] + [(predicate-implies? ret3 false-rec) + (pred-env-rebase t-types2 types1 new-types)] + [(and (eq? types2 t-types2) + (eq? types3 t-types3)) + #f] ; don't calculate t-types when it will be equal to new-types + [else + (pred-env-union/super-base t-types2 t-types1 + t-types3 f-types1 + types1 + new-types)]) + (cond + [(not (eq? ctxt 'test)) + #f] ; don't calculate f-types outside a test context + [(predicate-implies-not? ret2 false-rec) + (pred-env-rebase f-types3 types1 new-types)] + [(predicate-implies-not? ret3 false-rec) + (pred-env-rebase f-types2 types1 new-types)] + [(and (eq? types2 f-types2) + (eq? types3 f-types3)) + #f] ; don't calculate t-types when it will be equal to new-types + [else + (pred-env-union/super-base f-types2 t-types1 + f-types3 f-types1 + types1 + new-types)])))])))])] + [(set! ,maybe-src ,x ,[cptypes : e 'value types -> e ret types t-types f-types]) + (values `(set! ,maybe-src ,x ,e) void-rec types #f #f)] + [(call ,preinfo ,pr ,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) + (let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] [ret (primref->result-predicate pr)] + ;; AWK: this seems a bit premature, in some cases ir is not used, + ;; AWK: meaning we are constructing this for no reason, and in + ;; AWK: some cases we are reconstructing exactly this call [ir `(call ,preinfo ,pr ,e* ...)]) (let-values ([(ret t) (let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t]) @@ -873,77 +877,67 @@ Notes: [(clause (,x* ...) ,interface ,body) (let-values ([(body ret types t-types f-types) (cptypes body 'value types)]) + (for-each (lambda (x) (prelex-operand-set! x #f)) x*) (with-output-language (Lsrc CaseLambdaClause) `(clause (,x* ...) ,interface ,body)))])) cl*)]) (values `(case-lambda ,preinfo ,cl* ...) 'procedure #f #f #f))] - [(call ,preinfo ,e0 ,e* ...) - (let* ([e/r/t* (map (lambda (e) - (let-values ([(e r t t-t f-t) - (cptypes e 'value types)]) - (list e r t))) - e*)] - [e* (map car e/r/t*)] - [r* (map cadr e/r/t*)] - [t* (map caddr e/r/t*)] - [t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]) - (nanopass-case (Lsrc Expr) e0 - [(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) - ; We are sure that body will run and that it will be run after the evaluation of the arguments, - ; so we can use the types discovered in the arguments and also use the ret and types from the body. - (guard (fx= interface (length e*))) - (let ([t (fold-left pred-env-add t x* r*)]) - (let-values ([(body ret n-types t-types f-types) - (cptypes body ctxt t)]) - (let* ([e0 `(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body))] - [new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] - [t-types (and (eq? ctxt 'test) - (not (eq? n-types t-types)) - (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] - [f-types (and (eq? ctxt 'test) - (not (eq? n-types f-types)) - (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) - (values `(call ,preinfo ,e0 ,e* ...) - ret new-types t-types f-types))))] - [(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) - ; We are sure that body will run and that it will be run after the evaluation of the arguments, - ; but this will raise an error. TODO: change body to (void) because it will never run. - (guard (not (fx= interface (length e*)))) - (let-values ([(body ret types t-types f-types) - (cptypes body 'value t)]) - (let ([e0 `(case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body))]) - (values `(call ,preinfo ,e0 ,e* ...) - 'bottom #f #f #f)))] - [(case-lambda ,preinfo2 ,cl* ...) - ; We are sure that it will run after the arguments are evaluated, - ; so we can effectively delay the evaluation of the lambda and use more types inside it. - ; TODO: (difficult) Try to use the ret vales and discovered types. - (let-values ([(e0 ret types t-types f-types) - (cptypes e0 'value t)]) - (values `(call ,preinfo ,e0 ,e* ...) - #f t #f #f))] - [else - ; It's difficult to be sure the order the code will run, - ; so assume that the expression may be evaluated before the arguments. - (let-values ([(e0 ret0 types0 t-types0 f-types0) - (cptypes e0 'value types)]) - (let* ([t (pred-env-intersect/base t types0 types)] - [t (pred-env-add/ref t e0 'procedure)]) - (values `(call ,preinfo ,e0 ,e* ...) - #f t #f #f)))]))] - [(letrec ((,x* ,e*) ...) ,body) - (let* ([e/r/t* (map (lambda (e) - (let-values ([(e ret types t-types f-types) - (cptypes e 'value types)]) - (list e ret types))) - e*)] - [e* (map car e/r/t*)] - [r* (map cadr e/r/t*)] - [t* (map caddr e/r/t*)] - [t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] + [(call ,preinfo (case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...) + ,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) + ;; pulled from cpnanopass + (define find-matching-clause + (lambda (len x** interface* body* kfixed kvariable kfail) + (let f ([x** x**] [interface* interface*] [body* body*]) + (if (null? interface*) + (kfail) + (let ([interface (car interface*)]) + (if (fx< interface 0) + (let ([nfixed (fxlognot interface)]) + (if (fx>= len nfixed) + (kvariable nfixed (car x**) (car body*)) + (f (cdr x**) (cdr interface*) (cdr body*)))) + (if (fx= interface len) + (kfixed (car x**) (car body*)) + (f (cdr x**) (cdr interface*) (cdr body*))))))))) + (define finish + (lambda (x* interface body t) + (let-values ([(body ret n-types t-types f-types) + (cptypes body ctxt t)]) + (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] + [t-types (and (eq? ctxt 'test) + (not (eq? n-types t-types)) + (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] + [f-types (and (eq? ctxt 'test) + (not (eq? n-types f-types)) + (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) + (for-each (lambda (x) (prelex-operand-set! x #f)) x*) + (values + `(call ,preinfo (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...) + ret new-types t-types f-types))))) + (let ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] + [len (length e*)]) + (find-matching-clause (length e*) x** interface* body* + (lambda (x* body) (finish x* len body (fold-left pred-env-add t x* r*))) + (lambda (nfixed x* body) + (finish x* (fxlognot nfixed) body + (fold-left pred-env-add t x* + (let f ([i nfixed] [r* r*]) + (if (fx= i 0) + (list (if (null? r*) 'null 'pair)) + (cons (car r*) (f (fx- i 1) (cdr r*)))))))) + (lambda () (values ir 'bottom #f #f #f))))] + [(call ,preinfo ,[cptypes : e0 'value types -> e0 ret0 types0 t-types0 f-types0] + ,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) + (values `(call ,preinfo ,e0 ,e* ...) + #f (pred-env-add/ref + (pred-env-intersect/base + (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*) + types0 types) e0 'procedure) #f #f)] + [(letrec ((,x* ,[cptypes : e* 'value types -> e* r* t* t-t* t-f*]) ...) ,body) + (let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] [t (fold-left pred-env-add t x* r*)]) (let-values ([(body ret n-types t-types f-types) - (cptypes body ctxt t)]) + (cptypes body ctxt t)]) (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] [t-types (and (eq? ctxt 'test) (not (eq? n-types t-types)) @@ -951,6 +945,7 @@ Notes: [f-types (and (eq? ctxt 'test) (not (eq? n-types f-types)) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) + (for-each (lambda (x) (prelex-operand-set! x #f)) x*) (values `(letrec ([,x* ,e*] ...) ,body) ret new-types t-types f-types))))] [(letrec* ((,x* ,e*) ...) ,body) @@ -971,82 +966,57 @@ Notes: [f-types (and (eq? ctxt 'test) (not (eq? n-types f-types)) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) + (for-each (lambda (x) (prelex-operand-set! x #f)) x*) (values `(letrec* ([,x* ,e*] ...) ,body) ret new-types t-types f-types))))] [,pr (values ir (and (all-set? (prim-mask proc) (primref-flags pr)) 'procedure) #f #f #f)] - [(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) - (let-values ([(e ret types t-types f-types) - (cptypes e 'value types)]) - (values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) - #f types #f #f))] - [(fcallable ,conv ,e (,arg-type* ...) ,result-type) - (let-values ([(e ret types t-types f-types) - (cptypes e 'value types)]) - (values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) - #f types #f #f))] - [(record ,rtd ,rtd-expr ,e* ...) - (let-values ([(rtd-expr ret-re types-re t-types-re f-types-re) - (cptypes rtd-expr 'value types)]) - (let* ([e/r/t* (map (lambda (e) - (let-values ([(e ret types t-types f-types) - (cptypes e 'value types)]) - (list e ret types))) - e*)] - [e* (map car e/r/t*)] - #;[r* (map cadr e/r/t*)] - [t* (map caddr e/r/t*)]) - (values `(record ,rtd ,rtd-expr ,e* ...) - (rtd->record-predicate rtd-expr) - (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*) - #f #f)))] - [(record-ref ,rtd ,type ,index ,e) - (let-values ([(e ret types t-types f-types) - (cptypes e 'value types)]) - (values `(record-ref ,rtd ,type ,index ,e) - #f - (pred-env-add/ref types e '$record) - #f #f))] - [(record-set! ,rtd ,type ,index ,e1 , e2) ;can they be reordered? - (let-values ([(e1 ret1 types1 t-types1 f-types1) - (cptypes e1 'value types)] - [(e2 ret2 types2 t-types2 f-types2) - (cptypes e2 'value types)]) - (values `(record-set! ,rtd ,type ,index ,e1 ,e2) - void-rec - (pred-env-add/ref (pred-env-intersect/base types1 types2 types) - e1 '$record) - #f #f))] + [(foreign ,conv ,name ,[cptypes : e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type) + (values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) + #f types #f #f)] + [(fcallable ,conv ,[cptypes : e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type) + (values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) + #f types #f #f)] + [(record ,rtd ,[cptypes : rtd-expr 'value types -> rtd-expr ret-re types-re t-types-re f-types-re] + ,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) + (values `(record ,rtd ,rtd-expr ,e* ...) + (rtd->record-predicate rtd-expr) + (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*) + #f #f)] + [(record-ref ,rtd ,type ,index ,[cptypes : e 'value types -> e ret types t-types f-types]) + (values `(record-ref ,rtd ,type ,index ,e) + #f + (pred-env-add/ref types e '$record) + #f #f)] + [(record-set! ,rtd ,type ,index ,[cptypes : e1 'value types -> e1 ret1 types1 t-types1 f-types1] + ,[cptypes : e2 'value types -> e2 ret2 types2 t-types2 f-types2]) ;can they be reordered? + (values `(record-set! ,rtd ,type ,index ,e1 ,e2) + void-rec + (pred-env-add/ref (pred-env-intersect/base types1 types2 types) + e1 '$record) + #f #f)] [(record-type ,rtd ,[cptypes : e 'value types -> e ret types t-types f-types]) (values `(record-type ,rtd ,e) #f types #f #f)] [(record-cd ,rcd ,rtd-expr ,[cptypes : e 'value types -> e ret types t-types f-types]) (values `(record-cd ,rcd ,rtd-expr ,e) #f types #f #f)] - [(immutable-list (,e* ...) ,e) - (let ([e* (map (lambda (e) - (let-values ([(e ret types t-types f-types) - (cptypes e 'value types)]) - e)) - e*)]) - (let-values ([(e ret types t-types f-types) - (cptypes e 'value types)]) - (values `(immutable-list (,e* ...) ,e) - ret types #f #f)))] #;CHECK + [(immutable-list (,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) + ,[cptypes : e 'value types -> e ret types t-types f-types]) + (values `(immutable-list (,e* ...) ,e) + ret types #f #f)] #;CHECK [(moi) (values ir #f #f #f #f)] [(pariah) (values ir void-rec #f #f #f)] - [(cte-optimization-loc ,box ,e) - (let-values ([(e ret types t-types f-types) - (cptypes e 'value types)]) - (values `(cte-optimization-loc ,box ,e) - ret types #f #f))] #;CHECK + [(cte-optimization-loc ,box ,[cptypes : e 'value types -> e ret types t-types f-types]) + (values `(cte-optimization-loc ,box ,e) + ret types #f #f)] #;CHECK [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] [(profile ,src) (values ir #f #f #f #f)] #;[else (values ir #f #f #f #f)] - [else ($oops who "unrecognized record ~s" ir)]] - (Expr ir ctxt types)] + [else ($oops who "unrecognized record ~s" ir)]) + (Expr ir ctxt types)) (define (cptypes ir ctxt types) (let-values ([(ir ret r-types t-types f-types) @@ -1060,4 +1030,4 @@ Notes: (let-values ([(ir ret types t-types f-types) (cptypes ir 'value pred-env-empty)]) ir)) -]] +)) diff --git a/s/front.ss b/s/front.ss index ad4dc30c87..106144f56a 100644 --- a/s/front.ss +++ b/s/front.ss @@ -104,6 +104,8 @@ (define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t)))) +(define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t)))) + (define machine-type (lambda () (constant machine-type-name))) diff --git a/s/fxmap.ss b/s/fxmap.ss index 379aaceb69..9bd3c38f4f 100644 --- a/s/fxmap.ss +++ b/s/fxmap.ss @@ -39,18 +39,18 @@ ;; record types (define-record-type $branch - [fields prefix mask left right count changes] - [nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-1}] - [sealed #t]) + (fields prefix mask left right count changes) + (nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-1}) + (sealed #t)) (define-record-type $leaf - [fields key val changes] - [nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-1}] - [sealed #t]) + (fields key val changes) + (nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-1}) + (sealed #t)) (define-record-type $empty - [nongenerative #{$empty pfwk1nal7cs5dornqtzvda91m-0}] - [sealed #t]) + (nongenerative #{$empty pfwk1nal7cs5dornqtzvda91m-0}) + (sealed #t)) ;; constants @@ -272,9 +272,9 @@ (define (join* p1 d1 p2 d2) (cond - [($empty? d1) d2] - [($empty? d2) d1] - [else (join p1 d1 p2 d2)])) + [($empty? d1) d2] + [($empty? d2) d1] + [else (join p1 d1 p2 d2)])) (define (branching-bit p m) (highest-set-bit (fxxor p m))) @@ -282,14 +282,24 @@ (define-syntax-rule (mask h m) (fxand (fxior h (fx1- m)) (fxnot m))) - (define (highest-set-bit x1) - (let* ([x2 (fxior x1 (fxsrl x1 1))] - [x3 (fxior x2 (fxsrl x2 2))] - [x4 (fxior x3 (fxsrl x3 4))] - [x5 (fxior x4 (fxsrl x4 8))] - [x6 (fxior x5 (fxsrl x5 16))] - [x7 (fxior x6 (fxsrl x6 32))]) - (fxxor x7 (fxsrl x7 1)))) + (define highest-set-bit + (if (fx= (fixnum-width) 61) + (lambda (x1) + (let* ([x2 (fxior x1 (fxsrl x1 1))] + [x3 (fxior x2 (fxsrl x2 2))] + [x4 (fxior x3 (fxsrl x3 4))] + [x5 (fxior x4 (fxsrl x4 8))] + [x6 (fxior x5 (fxsrl x5 16))] + [x7 (fxior x6 (fxsrl x6 32))]) + (fxxor x7 (fxsrl x7 1)))) + (lambda (x1) + (let* ([x2 (fxior x1 (fxsrl x1 1))] + [x3 (fxior x2 (fxsrl x2 2))] + [x4 (fxior x3 (fxsrl x3 4))] + [x5 (fxior x4 (fxsrl x4 8))] + [x6 (fxior x5 (fxsrl x5 16))]) + (fxxor x6 (fxsrl x6 1)))))) + (define-syntax-rule (nomatch? h p m) (not (fx= (mask h m) p))) diff --git a/s/primdata.ss b/s/primdata.ss index 00b633e485..1a24aff432 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -871,9 +871,9 @@ (make-date [sig [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-fixnum) -> (date)] [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)]] [flags alloc]) - (make-time [sig [(sub-symbol sub-ufixnum sub-fixnum) -> (time)]] [flags alloc]) + (make-time [sig [(sub-symbol sub-ufixnum exact-integer) -> (time)]] [flags alloc]) (set-time-nanosecond! [sig [(time sub-uint) -> (void)]] [flags true]) - (set-time-second! [sig [(time sub-fixnum) -> (void)]] [flags true]) + (set-time-second! [sig [(time exact-integer) -> (void)]] [flags true]) (set-time-type! [sig [(time sub-symbol) -> (void)]] [flags true]) (subtract-duration (sig [(time time) -> (time)]) [flags alloc]) (subtract-duration! (sig [(time time) -> (time)]) [flags alloc]) @@ -886,7 +886,7 @@ (time-difference (sig [(time time) -> (time)]) [flags alloc]) (time-difference! (sig [(time time) -> (time)]) [flags alloc]) (time-nanosecond [sig [(time) -> (uint)]] [flags mifoldable discard true]) - (time-second [sig [(time) -> (fixnum)]] [flags mifoldable discard true]) + (time-second [sig [(time) -> (exact-integer)]] [flags mifoldable discard true]) (time-type [sig [(time) -> (symbol)]] [flags mifoldable discard true]) (time-utc->date [sig [(time) (time sub-fixnum) -> (date)]] [flags alloc]) ) @@ -948,6 +948,7 @@ (default-record-hash-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags]) (enable-cross-library-optimization [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) + (enable-type-recovery [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags]) (expand-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags]) (expand/optimize-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags]) From 62ae3ff4e6af970952568189bcbc4846a6c941f5 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Fri, 6 Apr 2018 18:22:10 -0300 Subject: [PATCH 08/11] Additional improvements in cptypes original commit: e53bae2d4ac549ac466d5f9942a839d624fb58fe --- s/cptypes.ss | 224 +++++++++++++++++++++++++++------------------------ s/fxmap.ss | 141 +++++++++++++++++++++++++------- 2 files changed, 229 insertions(+), 136 deletions(-) diff --git a/s/cptypes.ss b/s/cptypes.ss index d2735a84e4..5861e3f5e8 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -29,14 +29,15 @@ Notes: + results ir: the optimized expression ret: type of the result of the expression - types: like the types in the argument, with addition of the type discover - during the optimization of the expression + types: like the types in the argument, with the addition of the types + discover during the optimization of the expression t-types: types to be used in case the expression is not #f, to be used in the "then" branch of an if. - If left as #f it will be automatically replaced with a copy of - types by the wrapper. This is usually only filled in a text context. - f-types: idem for the "else" branch. (if x (something) (here x is #f)) + It may be #f, and in this case the `if` clause will use the value + of types as a replacement. + (Also the clauses for `let[rec/*]` handle the #f case specialy.) + f-types: idem for the "else" branch. (if x (something) ) - predicate: They may be: @@ -46,9 +47,9 @@ Notes: * a nanopass-quoted value that is okay-to-copy?, like `(quote 0) `(quote 5) `(quote #t) `(quote '()) (this doesn't includes `(quote )) - * a [normal] list ($record/rtd ) to signal that it's a + * a record #[pred-$record/rtd ] to signal that it's a record of type - * a [normal] list ($record/ref ) to signal that it's a + * a record #[pred-$record/ref ] to signal that it's a record of a type that is stored in the variable (these may collide with other records) * TODO?: add something to indicate that x is a procedure to @@ -125,6 +126,16 @@ Notes: (make-seq ctxt (car e*) (make-seq* ctxt (cdr e*)))))) ) + (define-record-type pred-$record/rtd + (fields rtd) + (nongenerative #{pred-$record/rtd wnquzwrp8wl515lhz2url8sjc-0}) + (sealed #t)) + + (define-record-type pred-$record/ref + (fields ref) + (nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-0}) + (sealed #t)) + (module (pred-env-empty pred-env-add pred-env-remove/base pred-env-lookup pred-env-intersect/base pred-env-union/super-base @@ -169,7 +180,6 @@ Notes: ; 'box _and_ 'vector -> 'bottom ; 'number _and_ 'exact-integer -> 'exact-integer (define (pred-env-intersect/base types from base) - #;(display (list (fxmap-changes from) (fxmap-changes types))) (cond [(fx> (fxmap-changes from) (fxmap-changes types)) (pred-env-intersect/base from types base)] @@ -337,10 +347,10 @@ Notes: (nanopass-case (Lsrc Expr) rtd [(quote ,d) (guard (record-type-descriptor? d)) - (list '$record/rtd d)] + (make-pred-$record/rtd d)] [(ref ,maybe-src ,x) (guard (not (prelex-assigned x))) - (list '$record/ref x)] + (make-pred-$record/ref x)] [(record-type ,rtd ,e) (rtd->record-predicate e)] [else '$record])] @@ -376,7 +386,7 @@ Notes: [eof-object? eof-rec] [bwp-object? bwp-rec] [list? (if (not extend?) null-rec 'null-or-pair)] - [else ((if extend? cdr car);--------------------------------------------------- + [else ((if extend? cdr car) (case name [(record? record-type-descriptor?) '(bottom . $record)] [(integer? rational?) '(exact-integer . real)] @@ -413,7 +423,7 @@ Notes: [eof-object eof-rec] [bwp-object bwp-rec] [list (if (not extend?) null-rec 'null-or-pair)] ;fake-predicate - [else ((if extend? cdr car);--------------------------------------------------- + [else ((if extend? cdr car) (case name [(record rtd) '(bottom . $record)] [(bit length ufixnum pfixnum) '(bottom . fixnum)] @@ -449,27 +459,25 @@ Notes: (nanopass-case (Lsrc Expr) y [(quote ,d1) (nanopass-case (Lsrc Expr) x - [(quote ,d2) (eqv? d1 d2)] #;CHECK ;eq?/eqv?/equal? + [(quote ,d2) (eqv? d1 d2)] [else #f])] [else #f]))] - [(and (pair? y) (pair? (cdr y))) - (and (pair? x) (pair? (cdr x)) - (cond - [(eq? (car y) '$record/rtd) - (and (eq? (car x) '$record/rtd) - (let ([y-rtd (cadr y)]) - (cond - [(record-type-sealed? y-rtd) - (eqv? (cadr x) y-rtd)] - [else - (let loop ([x-rtd (cadr x)]) - (or (eqv? x-rtd y-rtd) - (let ([xp (record-type-parent x-rtd)]) - (and xp (loop xp)))))])))] - [(eq? (car y) '$record/ref) - (and (eq? (car x) '$record/ref) - (eq? (cadr x) (cadr y)))] - [else #f]))] + [(pred-$record/rtd? y) + (and (pred-$record/rtd? x) + (let ([x-rtd (pred-$record/rtd-rtd x)] + [y-rtd (pred-$record/rtd-rtd y)]) + (cond + [(record-type-sealed? y-rtd) + (eqv? x-rtd y-rtd)] + [else + (let loop ([x-rtd x-rtd]) + (or (eqv? x-rtd y-rtd) + (let ([xp-rtd (record-type-parent x-rtd)]) + (and xp-rtd (loop xp-rtd)))))])))] + [(pred-$record/ref? y) + (and (pred-$record/ref? x) + (eq? (pred-$record/ref-ref x) + (pred-$record/ref-ref y)))] [(case y [(null-or-pair) (or (eq? x 'pair) (check-constant-is? x null?))] @@ -496,8 +504,8 @@ Notes: [(true) (and (not (check-constant-is? x not)) (not (eq? x 'boolean)) (not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f - [($record) (or (and (pair? x) (eq? (car x) '$record/rtd)) - (and (pair? x) (eq? (car x) '$record/ref)) + [($record) (or (pred-$record/rtd? x) + (pred-$record/ref? x) (check-constant-is? x #3%$record?))] [(vector) (check-constant-is? x vector?)] ; i.e. '#() [(string) (check-constant-is? x string?)] ; i.e. "" @@ -510,14 +518,12 @@ Notes: (define (predicate-implies-not? x y) (and x y - ; a $record/ref may be any other kind or record - (not (and (pair? x) - (eq? (car x) '$record/ref) + ; a pred-$record/ref may be any other kind or record + (not (and (pred-$record/ref? x) (predicate-implies? y '$record))) - (not (and (pair? y) - (eq? (car y) '$record/ref) + (not (and (pred-$record/ref? y) (predicate-implies? x '$record))) - ; boolean and true may be #f + ; boolean and true may be a #t (not (and (eq? x 'boolean) (eq? y 'true))) (not (and (eq? y 'boolean) @@ -616,19 +622,19 @@ Notes: (define (primref->unsafe-primref pr) (lookup-primref 3 (primref-name pr))) - (define-pass cptypes/raw : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types) + (define-pass cptypes : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types) (Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types) [(quote ,d) - (values ir (datum->predicate d ir) #f #f #f)] + (values ir (datum->predicate d ir) types #f #f)] [(ref ,maybe-src ,x) (case ctxt [(test) (let ([t (pred-env-lookup types x)]) (cond [(predicate-implies-not? t false-rec) - (values true-rec true-rec #f #f #f)] + (values true-rec true-rec types #f #f)] [(predicate-implies? t false-rec) - (values false-rec false-rec #f #f #f)] + (values false-rec false-rec types #f #f)] [else (values ir t types @@ -640,12 +646,12 @@ Notes: [(Lsrc? t) (nanopass-case (Lsrc Expr) t [(quote ,d) - (values t t #f #f #f)] + (values t t types #f #f)] [else - (values ir t #f #f #f)])] + (values ir t types #f #f)])] [else - (values ir t #f #f #f)]))])] - [(seq ,[cptypes : e1 'effect types -> e1 ret1 types t-types f-types] ,e2) + (values ir t types #f #f)]))])] + [(seq ,[e1 'effect types -> e1 ret1 types t-types f-types] ,e2) (cond [(predicate-implies? ret1 'bottom) (values e1 ret1 types #f #f)] @@ -653,7 +659,7 @@ Notes: (let-values ([(e2 ret types t-types f-types) (cptypes e2 ctxt types)]) (values (make-seq ctxt e1 e2) ret types t-types f-types))])] - [(if ,[cptypes : e1 'test types -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3) + [(if ,[e1 'test types -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3) (cond [(predicate-implies? ret1 'bottom) ;check bottom first (values e1 ret1 types #f #f)] @@ -666,10 +672,16 @@ Notes: (cptypes e3 ctxt types1)]) (values (make-seq ctxt e1 e3) ret types t-types f-types))] [else - (let-values ([(e2 ret2 types2 t-types2 f-types2) - (cptypes e2 ctxt t-types1)] - [(e3 ret3 types3 t-types3 f-types3) - (cptypes e3 ctxt f-types1)]) + (let*-values ([(t-types1) (or t-types1 types1)] + [(f-types1) (or f-types1 types1)] + [(e2 ret2 types2 t-types2 f-types2) + (cptypes e2 ctxt t-types1)] + [(t-types2) (or t-types2 types2)] + [(f-types2) (or f-types2 types2)] + [(e3 ret3 types3 t-types3 f-types3) + (cptypes e3 ctxt f-types1)] + [(t-types3) (or t-types3 types3)] + [(f-types3) (or f-types3 types3)]) (let ([ir `(if ,e1 ,e2 ,e3)]) (cond [(predicate-implies? ret2 'bottom) ;check bottom first @@ -720,15 +732,11 @@ Notes: f-types3 f-types1 types1 new-types)])))])))])] - [(set! ,maybe-src ,x ,[cptypes : e 'value types -> e ret types t-types f-types]) + [(set! ,maybe-src ,x ,[e 'value types -> e ret types t-types f-types]) (values `(set! ,maybe-src ,x ,e) void-rec types #f #f)] - [(call ,preinfo ,pr ,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) + [(call ,preinfo ,pr ,[e* 'value types -> e* r* t* t-t* f-t*] ...) (let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] - [ret (primref->result-predicate pr)] - ;; AWK: this seems a bit premature, in some cases ir is not used, - ;; AWK: meaning we are constructing this for no reason, and in - ;; AWK: some cases we are reconstructing exactly this call - [ir `(call ,preinfo ,pr ,e* ...)]) + [ret (primref->result-predicate pr)]) (let-values ([(ret t) (let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t]) (if (null? e*) @@ -743,9 +751,9 @@ Notes: (pred-env-add/ref t (car e*) pred)))))]) (cond [(predicate-implies? ret 'bottom) - (values ir ret t #f #f)] + (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)] [(not (arity-okay? (primref-arity pr) (length e*))) - (values ir 'bottom t #f #f)] + (values `(call ,preinfo ,pr ,e* ...) 'bottom t #f #f)] [(and (fx= (length e*) 2) (or (eq? (primref-name pr) 'eq?) (eq? (primref-name pr) 'eqv?))) @@ -759,7 +767,9 @@ Notes: (values (make-seq ctxt (make-seq 'effect e1 e2) false-rec) false-rec t #f #f)] [else - (values ir ret types + (values `(call ,preinfo ,pr ,e* ...) + ret + types (and (eq? ctxt 'test) (pred-env-add/ref (pred-env-add/ref t e1 r2) @@ -780,13 +790,15 @@ Notes: (values (make-seq ctxt (car e*) false-rec) false-rec t #f #f)] [else - (values ir ret types + (values `(call ,preinfo ,pr ,e* ...) + ret + types (and (eq? ctxt 'test) (pred-env-add/ref t (car e*) pred)) #f)]))]))] [(and (fx>= (length e*) 1) (eq? (primref-name pr) '$record)) - (values ir (rtd->record-predicate (car e*)) t #f #f)] + (values `(call ,preinfo ,pr ,e* ...) (rtd->record-predicate (car e*)) t #f #f)] [(and (fx= (length e*) 2) (or (eq? (primref-name pr) 'record?) (eq? (primref-name pr) '$sealed-record?))) @@ -823,7 +835,9 @@ Notes: (pred-env-add/ref types (car e*) pred)) #f))] [else - (values ir ret types + (values `(call ,preinfo ,pr ,e* ...) + ret + types (and (eq? ctxt 'test) (pred-env-add/ref types (car e*) pred)) #f)]))] @@ -843,7 +857,7 @@ Notes: (values `(call ,preinfo ,pr ,e* ...) ret t #f #f))] [else - (values ir ret t #f #f)])] + (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])] [(and (fx= (length e*) 1) (eq? (primref-name pr) 'inexact?)) (cond @@ -859,7 +873,7 @@ Notes: (values `(call ,preinfo ,pr ,e* ...) ret t #f #f))] [else - (values ir ret t #f #f)])] + (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])] [(and (not (all-set? (prim-mask unsafe) (primref-flags pr))) (all-set? (prim-mask safeongoodargs) (primref-flags pr)) (andmap (lambda (r n) @@ -870,7 +884,7 @@ Notes: (values `(call ,preinfo ,pr ,e* ...) ret types #f #f))] [else - (values ir ret t #f #f)])))] + (values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])))] [(case-lambda ,preinfo ,cl* ...) (let ([cl* (map (lambda (cl) (nanopass-case (Lsrc CaseLambdaClause) cl @@ -881,9 +895,9 @@ Notes: (with-output-language (Lsrc CaseLambdaClause) `(clause (,x* ...) ,interface ,body)))])) cl*)]) - (values `(case-lambda ,preinfo ,cl* ...) 'procedure #f #f #f))] + (values `(case-lambda ,preinfo ,cl* ...) 'procedure types #f #f))] [(call ,preinfo (case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...) - ,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) + ,[e* 'value types -> e* r* t* t-t* f-t*] ...) ;; pulled from cpnanopass (define find-matching-clause (lambda (len x** interface* body* kfixed kvariable kfail) @@ -905,9 +919,11 @@ Notes: (cptypes body ctxt t)]) (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] [t-types (and (eq? ctxt 'test) + t-types (not (eq? n-types t-types)) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] [f-types (and (eq? ctxt 'test) + f-types (not (eq? n-types f-types)) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) (for-each (lambda (x) (prelex-operand-set! x #f)) x*) @@ -925,24 +941,29 @@ Notes: (if (fx= i 0) (list (if (null? r*) 'null 'pair)) (cons (car r*) (f (fx- i 1) (cdr r*)))))))) - (lambda () (values ir 'bottom #f #f #f))))] - [(call ,preinfo ,[cptypes : e0 'value types -> e0 ret0 types0 t-types0 f-types0] - ,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) + (lambda () (values ir 'bottom types #f #f))))] + [(call ,preinfo ,[e0 'value types -> e0 ret0 types0 t-types0 f-types0] + ,[e* 'value types -> e* r* t* t-t* f-t*] ...) (values `(call ,preinfo ,e0 ,e* ...) - #f (pred-env-add/ref - (pred-env-intersect/base - (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*) - types0 types) e0 'procedure) #f #f)] - [(letrec ((,x* ,[cptypes : e* 'value types -> e* r* t* t-t* t-f*]) ...) ,body) + #f + (pred-env-add/ref + (pred-env-intersect/base + (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*) + types0 types) + e0 'procedure) + #f #f)] + [(letrec ((,x* ,[e* 'value types -> e* r* t* t-t* t-f*]) ...) ,body) (let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] [t (fold-left pred-env-add t x* r*)]) (let-values ([(body ret n-types t-types f-types) (cptypes body ctxt t)]) (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] [t-types (and (eq? ctxt 'test) + t-types (not (eq? n-types t-types)) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] [f-types (and (eq? ctxt 'test) + f-types (not (eq? n-types f-types)) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) (for-each (lambda (x) (prelex-operand-set! x #f)) x*) @@ -961,9 +982,11 @@ Notes: (cptypes body ctxt types)]) (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] [t-types (and (eq? ctxt 'test) + t-types (not (eq? n-types t-types)) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))] [f-types (and (eq? ctxt 'test) + f-types (not (eq? n-types f-types)) (fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))]) (for-each (lambda (x) (prelex-operand-set! x #f)) x*) @@ -972,60 +995,51 @@ Notes: [,pr (values ir (and (all-set? (prim-mask proc) (primref-flags pr)) 'procedure) - #f #f #f)] - [(foreign ,conv ,name ,[cptypes : e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type) + types #f #f)] + [(foreign ,conv ,name ,[e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type) (values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) #f types #f #f)] - [(fcallable ,conv ,[cptypes : e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type) + [(fcallable ,conv ,[e 'value types -> e ret types t-types f-types] (,arg-type* ...) ,result-type) (values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) #f types #f #f)] - [(record ,rtd ,[cptypes : rtd-expr 'value types -> rtd-expr ret-re types-re t-types-re f-types-re] - ,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) + [(record ,rtd ,[rtd-expr 'value types -> rtd-expr ret-re types-re t-types-re f-types-re] + ,[e* 'value types -> e* r* t* t-t* f-t*] ...) (values `(record ,rtd ,rtd-expr ,e* ...) (rtd->record-predicate rtd-expr) (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*) #f #f)] - [(record-ref ,rtd ,type ,index ,[cptypes : e 'value types -> e ret types t-types f-types]) + [(record-ref ,rtd ,type ,index ,[e 'value types -> e ret types t-types f-types]) (values `(record-ref ,rtd ,type ,index ,e) #f (pred-env-add/ref types e '$record) #f #f)] - [(record-set! ,rtd ,type ,index ,[cptypes : e1 'value types -> e1 ret1 types1 t-types1 f-types1] - ,[cptypes : e2 'value types -> e2 ret2 types2 t-types2 f-types2]) ;can they be reordered? + [(record-set! ,rtd ,type ,index ,[e1 'value types -> e1 ret1 types1 t-types1 f-types1] + ,[e2 'value types -> e2 ret2 types2 t-types2 f-types2]) (values `(record-set! ,rtd ,type ,index ,e1 ,e2) void-rec (pred-env-add/ref (pred-env-intersect/base types1 types2 types) e1 '$record) #f #f)] - [(record-type ,rtd ,[cptypes : e 'value types -> e ret types t-types f-types]) + [(record-type ,rtd ,[e 'value types -> e ret types t-types f-types]) (values `(record-type ,rtd ,e) #f types #f #f)] - [(record-cd ,rcd ,rtd-expr ,[cptypes : e 'value types -> e ret types t-types f-types]) + [(record-cd ,rcd ,rtd-expr ,[e 'value types -> e ret types t-types f-types]) (values `(record-cd ,rcd ,rtd-expr ,e) #f types #f #f)] - [(immutable-list (,[cptypes : e* 'value types -> e* r* t* t-t* f-t*] ...) - ,[cptypes : e 'value types -> e ret types t-types f-types]) + [(immutable-list (,[e* 'value types -> e* r* t* t-t* f-t*] ...) + ,[e 'value types -> e ret types t-types f-types]) (values `(immutable-list (,e* ...) ,e) - ret types #f #f)] #;CHECK - [(moi) (values ir #f #f #f #f)] - [(pariah) (values ir void-rec #f #f #f)] - [(cte-optimization-loc ,box ,[cptypes : e 'value types -> e ret types t-types f-types]) + ret types #f #f)] + [(moi) (values ir #f types #f #f)] + [(pariah) (values ir void-rec types #f #f)] + [(cte-optimization-loc ,box ,[e 'value types -> e ret types t-types f-types]) (values `(cte-optimization-loc ,box ,e) - ret types #f #f)] #;CHECK + ret types #f #f)] [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] - [(profile ,src) (values ir #f #f #f #f)] - #;[else (values ir #f #f #f #f)] + [(profile ,src) (values ir #f types #f #f)] [else ($oops who "unrecognized record ~s" ir)]) (Expr ir ctxt types)) - (define (cptypes ir ctxt types) - (let-values ([(ir ret r-types t-types f-types) - (cptypes/raw ir ctxt types)]) - (values ir - ret - (or r-types types) - (or t-types r-types types) - (or f-types r-types types)))) (lambda (ir) (let-values ([(ir ret types t-types f-types) (cptypes ir 'value pred-env-empty)]) diff --git a/s/fxmap.ss b/s/fxmap.ss index 9bd3c38f4f..d069a6ed37 100644 --- a/s/fxmap.ss +++ b/s/fxmap.ss @@ -33,6 +33,8 @@ ;; internals ; $branch? make-$branch $branch-prefix $branch-mask $branch-left $branch-right ; $leaf? make-$leaf $leaf-key $leaf-val + + ;; We treat $empty as a singleton, so don't use these functions. ; $empty? make-$empty ) @@ -52,18 +54,29 @@ (nongenerative #{$empty pfwk1nal7cs5dornqtzvda91m-0}) (sealed #t)) - ;; constants + (define-syntax let-branch + (syntax-rules () + [(_ ([(p m l r) d] ...) exp ...) + (let ([p ($branch-prefix d)] ... + [m ($branch-mask d)] ... + [l ($branch-left d)] ... + [r ($branch-right d)] ...) + exp ...)])) + + ;; constants & empty (define empty-fxmap (make-$empty)) + (define (fxmap-empty? x) (eq? empty-fxmap x)) + ;; predicate (define (fxmap? x) (or ($branch? x) ($leaf? x) - ($empty? x))) + (eq? empty-fxmap x))) - ;; count, changes & empty + ;; count & changes (define (fxmap-count d) (cond @@ -80,8 +93,6 @@ ($leaf-changes d)] [else 0])) - (define fxmap-empty? $empty?) - ;; ref (define (fxmap-ref/leaf d key) @@ -251,13 +262,13 @@ (fx+ (fxmap-changes l) (fxmap-changes r)))) (define (br* p m l r) - (cond [($empty? r) l] - [($empty? l) r] + (cond [(eq? empty-fxmap r) l] + [(eq? empty-fxmap l) r] [else (br p m l r)])) (define (br*/base p m l r base) - (cond [($empty? r) l] - [($empty? l) r] + (cond [(eq? empty-fxmap r) l] + [(eq? empty-fxmap l) r] [(and ($branch? base) (eq? l ($branch-left base)) (eq? r ($branch-right base))) @@ -272,8 +283,8 @@ (define (join* p1 d1 p2 d2) (cond - [($empty? d1) d2] - [($empty? d2) d1] + [(eq? empty-fxmap d1) d2] + [(eq? empty-fxmap d2) d1] [else (join p1 d1 p2 d2)])) (define (branching-bit p m) @@ -349,10 +360,10 @@ (cond [(fx= k1 k2) (f d1 d2)] [else (join* k1 (g1 d1) k2 (g2 d2))]))] - [else ; ($empty? d1) + [else ; (eq? empty-fxmap d1) (g2 d2)])))] - [else ;; ($empty? d2) + [else ; (eq? empty-fxmap d2) (g1 d1)])] [($leaf? d1) @@ -373,20 +384,89 @@ (cond [(fx= k1 k2) (f d1 d2)] [else (join* k1 (g1 d1) k2 (g2 d2))]))] - [else ; ($empty? d2) + [else ; (eq? empty-fxmap d2) (g1 d1)])))] - [else ; ($empty? d1) + [else ; (eq? empty-fxmap d1) (g2 d2)])) - (define-syntax let-branch - (syntax-rules () - [(_ ([(p m l r) d] ...) exp ...) - (let ([p ($branch-prefix d)] ... - [m ($branch-mask d)] ... - [l ($branch-left d)] ... - [r ($branch-right d)] ...) - exp ...)])) + ;; merge* + ; like merge, but the result is (void) + + (define (fxmap-merge* f id g1 g2 d1 d2) + (define (merge* f id g1 g2 d1 d2) + (define-syntax go + (syntax-rules () + [(_ d1 d2) (merge* f id g1 g2 d1 d2)])) + + (cond + [(eq? d1 d2) (id d1)] + + [($branch? d1) + (cond + [($branch? d2) + (let-branch ([(p1 m1 l1 r1) d1] + [(p2 m2 l2 r2) d2]) + (cond + [(fx> m1 m2) (cond + [(nomatch? p2 p1 m1) (g1 d1) (g2 d2)] + [(fx<= p2 p1) (go l1 d2) (g1 r1)] + [else (g1 l1) (go r1 d2)])] + [(fx> m2 m1) (cond + [(nomatch? p1 p2 m2) (g1 d1) (g2 d2)] + [(fx<= p1 p2) (go d1 l2) (g2 r2)] + [else (g2 l2) (go d1 r2)])] + [(fx= p1 p2) (go l1 l2) (go r1 r2)] + [else (g1 d1) (g2 d2)]))] + + [else ; ($leaf? d2) + (let ([k2 ($leaf-key d2)]) + (let merge*0 ([d1 d1]) + (cond + [(eq? d1 d2) + (id d1)] + + [($branch? d1) + (let-branch ([(p1 m1 l1 r1) d1]) + (cond [(nomatch? k2 p1 m1) (g1 d1) (g2 d2)] + [(fx<= k2 p1) (merge*0 l1) (g1 r1)] + [else (g1 l1) (merge*0 r1)]))] + + [else ; ($leaf? d1) + (let ([k1 ($leaf-key d1)]) + (cond [(fx= k1 k2) (f d1 d2)] + [else (g1 d1) (g2 d2)]))])))])] + + [($leaf? d1) + (let ([k1 ($leaf-key d1)]) + (let merge*0 ([d2 d2]) + (cond + [(eq? d1 d2) + (id d1)] + + [($branch? d2) + (let-branch ([(p2 m2 l2 r2) d2]) + (cond [(nomatch? k1 p2 m2) (g1 d1) (g2 d2)] + [(fx<= k1 p2) (merge*0 l2) (g2 r2)] + [else (g2 l2) (merge*0 r2)]))] + + [else ; ($leaf? d2) + (let ([k2 ($leaf-key d2)]) + (cond [(fx= k1 k2) (f d1 d2)] + [else (g1 d1) (g2 d2)]))])))])) + + (cond + [(eq? d1 d2) + (id d1)] + [(eq? empty-fxmap d1) + (g2 d2)] + [(eq? empty-fxmap d2) + (g1 d1)] + [else + (merge* f id g1 g2 d1 d2)]) + (void)) + + ;; for-each (define (fxmap-for-each g1 d1) (cond @@ -395,17 +475,16 @@ (fxmap-for-each g1 ($branch-right d1))] [($leaf? d1) (g1 ($leaf-key d1) ($leaf-val d1))] - [else ; ($empty? d1) + [else ; (eq? empty-fxmap d1) (void)]) (void)) (define (fxmap-for-each/diff f g1 g2 d1 d2) - (fxmap-merge (lambda (prefix mask left right) (make-$empty)) - (lambda (x y) (f ($leaf-key x) ($leaf-val x) ($leaf-val y)) (make-$empty)) - (lambda (x) (make-$empty)) - (lambda (x) (fxmap-for-each g1 x) (make-$empty)) - (lambda (x) (fxmap-for-each g2 x) (make-$empty)) - d1 - d2) + (fxmap-merge* (lambda (x y) (f ($leaf-key x) ($leaf-val x) ($leaf-val y))) + (lambda (x) (void)) + (lambda (x) (fxmap-for-each g1 x)) + (lambda (x) (fxmap-for-each g2 x)) + d1 + d2) (void)) ) From 1a9cb566a529cee32c2cf67d555350c2d098a7c9 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Wed, 23 May 2018 12:00:00 -0300 Subject: [PATCH 09/11] Fix cptypes in multi-thread version Code by Andy Keep. original commit: 639f32cfc6f462fe9492d13b6fd246cb6be1df3f --- s/cptypes.ss | 37 +++++++++++++++++++------------------ 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/s/cptypes.ss b/s/cptypes.ss index 5861e3f5e8..9acb0ab52d 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -62,12 +62,14 @@ Notes: |# -(define $cptypes +(define $cptypes) (let () (import (nanopass)) (include "base-lang.ss") (include "fxmap.ss") + (define-pass cptypes : Lsrc (ir) -> Lsrc () + (definitions (define prelex-counter (let () (define count 0) @@ -621,8 +623,7 @@ Notes: (define (primref->unsafe-primref pr) (lookup-primref 3 (primref-name pr))) - - (define-pass cptypes : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types) +) (Expr : Expr (ir ctxt types) -> Expr (ret types t-types f-types) [(quote ,d) (values ir (datum->predicate d ir) types #f #f)] @@ -657,7 +658,7 @@ Notes: (values e1 ret1 types #f #f)] [else (let-values ([(e2 ret types t-types f-types) - (cptypes e2 ctxt types)]) + (Expr e2 ctxt types)]) (values (make-seq ctxt e1 e2) ret types t-types f-types))])] [(if ,[e1 'test types -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3) (cond @@ -665,21 +666,21 @@ Notes: (values e1 ret1 types #f #f)] [(predicate-implies-not? ret1 false-rec) (let-values ([(e2 ret types t-types f-types) - (cptypes e2 ctxt types1)]) + (Expr e2 ctxt types1)]) (values (make-seq ctxt e1 e2) ret types t-types f-types))] [(predicate-implies? ret1 false-rec) (let-values ([(e3 ret types t-types f-types) - (cptypes e3 ctxt types1)]) + (Expr e3 ctxt types1)]) (values (make-seq ctxt e1 e3) ret types t-types f-types))] [else (let*-values ([(t-types1) (or t-types1 types1)] [(f-types1) (or f-types1 types1)] [(e2 ret2 types2 t-types2 f-types2) - (cptypes e2 ctxt t-types1)] + (Expr e2 ctxt t-types1)] [(t-types2) (or t-types2 types2)] [(f-types2) (or f-types2 types2)] [(e3 ret3 types3 t-types3 f-types3) - (cptypes e3 ctxt f-types1)] + (Expr e3 ctxt f-types1)] [(t-types3) (or t-types3 types3)] [(f-types3) (or f-types3 types3)]) (let ([ir `(if ,e1 ,e2 ,e3)]) @@ -890,7 +891,7 @@ Notes: (nanopass-case (Lsrc CaseLambdaClause) cl [(clause (,x* ...) ,interface ,body) (let-values ([(body ret types t-types f-types) - (cptypes body 'value types)]) + (Expr body 'value types)]) (for-each (lambda (x) (prelex-operand-set! x #f)) x*) (with-output-language (Lsrc CaseLambdaClause) `(clause (,x* ...) ,interface ,body)))])) @@ -916,7 +917,7 @@ Notes: (define finish (lambda (x* interface body t) (let-values ([(body ret n-types t-types f-types) - (cptypes body ctxt t)]) + (Expr body ctxt t)]) (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] [t-types (and (eq? ctxt 'test) t-types @@ -956,7 +957,7 @@ Notes: (let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)] [t (fold-left pred-env-add t x* r*)]) (let-values ([(body ret n-types t-types f-types) - (cptypes body ctxt t)]) + (Expr body ctxt t)]) (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] [t-types (and (eq? ctxt 'test) t-types @@ -975,11 +976,11 @@ Notes: (if (null? x*) (values (reverse rev-e*) types) (let-values ([(e ret types t-types f-types) - (cptypes (car e*) 'value types)]) + (Expr (car e*) 'value types)]) (let ([types (pred-env-add types (car x*) ret)]) (loop (cdr x*) (cdr e*) types (cons e rev-e*))))))]) (let-values ([(body ret n-types t-types f-types) - (cptypes body ctxt types)]) + (Expr body ctxt types)]) (let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)] [t-types (and (eq? ctxt 'test) t-types @@ -1038,10 +1039,10 @@ Notes: [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] [(profile ,src) (values ir #f types #f #f)] [else ($oops who "unrecognized record ~s" ir)]) - (Expr ir ctxt types)) - - (lambda (ir) (let-values ([(ir ret types t-types f-types) - (cptypes ir 'value pred-env-empty)]) + (Expr ir 'value pred-env-empty)]) ir)) -)) + + (set! $cptypes cptypes) + +) From 6ff9e9ecd5cd218fda596df007060214d6a39f96 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Thu, 24 May 2018 00:23:52 -0300 Subject: [PATCH 10/11] Fix call case with rest argument in cptypes And add special case for list to reduce (pair? (list x y ...)) ==> (begin x y ... #t) original commit: 196bb8c18b604cd599e154c63f95a9d0117d4d6e --- mats/cptypes.ms | 66 +++++++++++++++++++++++++++++++++++++++++++++++++ s/cptypes.ss | 18 +++++++++++--- 2 files changed, 80 insertions(+), 4 deletions(-) diff --git a/mats/cptypes.ms b/mats/cptypes.ms index 0433672f35..0f06b004cb 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -26,6 +26,36 @@ #;[optimize-level (max (optimize-level) 2)]) (expand/optimize y)))])) +(define-syntax cptypes/nocp0-equivalent-expansion? + (syntax-rules () + [(_ x y) + (equivalent-expansion? + (parameterize ([enable-cp0 #f] + [#%$suppress-primitive-inlining #f] + #;[optimize-level (max (optimize-level) 2)]) + (expand/optimize x)) + (parameterize ([enable-cp0 #f] + [#%$suppress-primitive-inlining #f] + #;[optimize-level (max (optimize-level) 2)]) + (expand/optimize y)))])) + +(define-syntax cptypes/nocp0/alternative-equivalent-expansion? + (syntax-rules () + [(_ x y) + (equivalent-expansion? + (parameterize ([enable-cp0 #f] + [enable-type-recovery #f] + [run-cp0 (lambda (cp0 c) (#3%$cptypes c))] + [#%$suppress-primitive-inlining #f] + #;[optimize-level (max (optimize-level) 2)]) + (expand/optimize x)) + (parameterize ([enable-cp0 #f] + [enable-type-recovery #f] + [run-cp0 (lambda (cp0 c) (#3%$cptypes c))] + [#%$suppress-primitive-inlining #f] + #;[optimize-level (max (optimize-level) 2)]) + (expand/optimize y)))])) + (mat cptypes-handcoded (cptypes-equivalent-expansion? '(vector? (vector)) ;actually reduced by folding, not cptypes @@ -45,6 +75,12 @@ (cptypes-equivalent-expansion? '(pair? (cons 1 2)) #t) + (cptypes-equivalent-expansion? + '(pair? (list 1 2)) + #t) + (cptypes-equivalent-expansion? + '(pair? (list)) + #f) (cptypes-equivalent-expansion? '(lambda (x) (vector-set! x 0 0) (vector? x)) '(lambda (x) (vector-set! x 0 0) #t)) @@ -629,3 +665,33 @@ '(lambda (x) (when (number? x) (#2%odd? x))) '(lambda (x) (when (number? x) (#3%odd? x))))) ) + +(mat cptypes-rest-argument + (cptypes/nocp0-equivalent-expansion? + '((lambda (x . r) (pair? r)) 1) + '((lambda (x . r) #f) 1)) + (cptypes/nocp0-equivalent-expansion? + '((lambda (x . r) (null? r)) 1) + '((lambda (x . r) #t) 1)) + (cptypes/nocp0-equivalent-expansion? + '((lambda (x . r) (pair? r)) 1 2) + '((lambda (x . r) #t) 1 2)) + (cptypes/nocp0-equivalent-expansion? + '((lambda (x . r) (null? r)) 1 2) + '((lambda (x . r) #f) 1 2)) +) + +(mat cptypes-rest-argument/alternative + (cptypes/nocp0/alternative-equivalent-expansion? + '((lambda (x . r) (pair? r)) 1) + '((lambda (x . r) #f) 1)) + (cptypes/nocp0/alternative-equivalent-expansion? + '((lambda (x . r) (null? r)) 1) + '((lambda (x . r) #t) 1)) + (cptypes/nocp0/alternative-equivalent-expansion? + '((lambda (x . r) (pair? r)) 1 2) + '((lambda (x . r) #t) 1 2)) + (cptypes/nocp0/alternative-equivalent-expansion? + '((lambda (x . r) (null? r)) 1 2) + '((lambda (x . r) #f) 1 2)) +) diff --git a/s/cptypes.ss b/s/cptypes.ss index 9acb0ab52d..c940bd221c 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -195,7 +195,8 @@ Notes: (set! ret (pred-env-add/key ret key (pred-intersect x z))))) (lambda (key x) (set! ret (pred-env-add/key ret key x))) - (lambda (key x) (error 'pred-env-intersect/base "") (void)) + (lambda (key x) + ($impoops 'pred-env-intersect/base "unexpected value ~s in base environment ~s" x base)) from base) ret)])) @@ -233,7 +234,8 @@ Notes: ;x-> from ;z-> types (set! ret (pred-env-add/key ret key (pred-union x z))))) - (lambda (key x) (error 'pred-env-union/base "") (void)) + (lambda (key x) + ($impoops 'pred-env-union/from "unexpected value ~s in base environment ~s" x base)) from base) ret)) @@ -288,7 +290,8 @@ Notes: (if (eq? x z) (set! ret (fxmap-reset/base ret key new-base)) (set! ret (fxmap-advance/base ret key new-base))))) - (lambda (key x) (error 'pred-env-rebase "") (void)) + (lambda (key x) + ($impoops 'pred-env-rebase "unexpected value ~s in base environment ~s" x base)) new-base base) ret)) @@ -843,6 +846,13 @@ Notes: (pred-env-add/ref types (car e*) pred)) #f)]))] ; TODO: special case for call-with-values. + [(eq? (primref-name pr) 'list) + (cond + [(null? e*) + ;should have be reduced by cp0 + (values null-rec null-rec t #f #f)] + [else + (values `(call ,preinfo ,pr ,e* ...) 'pair t #f #f)])] [(and (fx= (length e*) 1) (eq? (primref-name pr) 'exact?)) (cond @@ -940,7 +950,7 @@ Notes: (fold-left pred-env-add t x* (let f ([i nfixed] [r* r*]) (if (fx= i 0) - (list (if (null? r*) 'null 'pair)) + (list (if (null? r*) null-rec 'pair)) (cons (car r*) (f (fx- i 1) (cdr r*)))))))) (lambda () (values ir 'bottom types #f #f))))] [(call ,preinfo ,[e0 'value types -> e0 ret0 types0 t-types0 f-types0] From ecc310106dce5149f14eb7678532011ff3db32fd Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Sun, 29 Jul 2018 19:58:15 -0300 Subject: [PATCH 11/11] more cptypes original commit: e04430806fc16e411dae8f8c9288f56e6e55a426 --- s/cprep.ss | 8 ++++++-- s/interpret.ss | 9 +++++++-- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/s/cprep.ss b/s/cprep.ss index 26665ac673..239231cf20 100644 --- a/s/cprep.ss +++ b/s/cprep.ss @@ -212,6 +212,10 @@ (if (eq? (subset-mode) 'system) ($system-environment) (interaction-environment))) + (define (cptypes x) + (if (enable-type-recovery) + ($cptypes x) + x)) (define e/o (lambda (who cte? x env) (define (go x) @@ -222,9 +226,9 @@ (let ([x ((run-cp0) (lambda (x) (set! cpletrec-ran? #t) - ($cpletrec ($cptypes ($cp0 x $compiler-is-loaded?)))) + ($cpletrec (cptypes ($cp0 x $compiler-is-loaded?)))) ($cpvalid x))]) - (if cpletrec-ran? x ($cpletrec x)))))))) + (if cpletrec-ran? x ($cpletrec (cptypes x))))))))) (unless (environment? env) ($oops who "~s is not an environment" env)) ; claim compiling-a-file to get cte as well as run-time code diff --git a/s/interpret.ss b/s/interpret.ss index aa1281f333..7a35b20fe6 100644 --- a/s/interpret.ss +++ b/s/interpret.ss @@ -645,6 +645,11 @@ (c-var-index-set! (car vars) i) (loop (cdr vars) regs (fx+ i 1))]))))) +(define (cptypes x) + (if (enable-type-recovery) + ($cptypes x)) + x) + (define-pass interpret-Lexpand : Lexpand (ir situation for-import? ofn eoo) -> * (val) (definitions (define (ibeval x1) @@ -654,9 +659,9 @@ (let ([x ((run-cp0) (lambda (x) (set! cpletrec-ran? #t) - ($cpletrec ($cptypes ($cp0 x #f)))) + ($cpletrec (cptypes ($cp0 x #f)))) x2)]) - (if cpletrec-ran? x ($cpletrec x))))] + (if cpletrec-ran? x ($cpletrec (cptypes x)))))] [x2b ($cpcheck x2a)] [x2b ($cpcommonize x2b)]) (when eoo (pretty-print ($uncprep x2b) eoo))