From 4991067ed7b901ec23fa1b3d0d09777eaa554f49 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Fri, 9 Feb 2018 10:21:00 -0300 Subject: [PATCH 1/2] Remove special case for (#2%map p '()) in cp0 So the reduced version checks that p is a procedure Also make the same change for #2%for-each. cp0.ss, 4.ms original commit: 5caa11c85bc74c0af25ac215d48b7f5f0c1d3e42 --- LOG | 4 ++++ mats/4.ms | 41 +++++++++++++++++++++++++++++++++++++++++ s/cp0.ss | 25 ++++++++++--------------- 3 files changed, 55 insertions(+), 15 deletions(-) diff --git a/LOG b/LOG index 8f01a213c5..f361b3eb9b 100644 --- a/LOG +++ b/LOG @@ -879,3 +879,7 @@ $verify-ftype-address if the address expression is a call to ftype-pointer-address. ftype.ss +- Remove special case for (#2%map p '()) in cp0 + so the reduced version checks that p is a procedure. + Also make the same change for #2%for-each. + cp0.ss, 4.ms diff --git a/mats/4.ms b/mats/4.ms index cda433d6d8..3177b42044 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -1079,6 +1079,10 @@ ((1 f k p u a) (2 g l q v b) (3 h m r w c) (4 i n s x d) (5 j o t y e)))) ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (map x))) + (error? ; nonprocedure + (map 3 '())) + (error? ; nonprocedure + (map 3 '() '())) (error? ; nonprocedure (map 3 '(a b c))) (error? ; nonprocedure @@ -1420,6 +1424,10 @@ 21) (procedure? (lambda (x) (fold-left x))) (procedure? (lambda (x) (fold-left x y))) + (error? ; nonprocedure + (for-left 3 0 '())) + (error? ; nonprocedure + (for-left 3 0 '() '())) (error? ; nonprocedure (fold-left 3 0 '(a b c))) (error? ; improper list @@ -1544,6 +1552,10 @@ ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (fold-right x))) (procedure? (lambda (x) (fold-right x y))) + (error? ; nonprocedure + (for-right 3 0 '())) + (error? ; nonprocedure + (for-right 3 0 '() '())) (error? ; nonprocedure (fold-right 3 0 '(a b c))) (error? ; improper list @@ -1722,11 +1734,24 @@ ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (for-each x))) + (error? ; nonprocedure + (for-each 3 '())) + (error? ; nonprocedure + (for-each 3 '() '())) (error? ; nonprocedure (for-each 3 '(a b c))) (error? ; nonprocedure (parameterize ([optimize-level 3]) (eval '(#2%for-each 3 '(a b c))))) + (error? ; nonprocedure + (parameterize ([optimize-level 3]) + (eval + '(let () + (define (f p b) + (unbox b) + (#2%for-each p (if (box? b) '() '(1 2 3))) + (list p (procedure? p))) + (f 7 (box 0)))))) (error? ; improper list (for-each pretty-print 'a)) (error? ; improper list @@ -2232,6 +2257,10 @@ (not (ormap (lambda (x y z) #t) '() '() '())) ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (ormap x))) + (error? ; nonprocedure + (ormap 3 '())) + (error? ; nonprocedure + (ormap 3 '() '())) (error? ; nonprocedure (ormap 3 '(a b c))) (error? ; improper list @@ -2333,6 +2362,10 @@ (eq? (andmap (lambda (x y z) #t) '() '() '()) #t) ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (andmap x))) + (error? ; nonprocedure + (andmap 3 '())) + (error? ; nonprocedure + (andmap 3 '() '())) (error? ; nonprocedure (andmap 3 '(a b c))) (error? ; improper list @@ -2434,6 +2467,10 @@ (not (exists (lambda (x y z) #t) '() '() '())) ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (exists x))) + (error? ; nonprocedure + (exists 3 '())) + (error? ; nonprocedure + (exists 3 '() '())) (error? ; nonprocedure (exists 3 '(a b c))) (error? ; improper list @@ -2535,6 +2572,10 @@ (eq? (for-all (lambda (x y z) #t) '() '() '()) #t) ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (for-all x))) + (error? ; nonprocedure + (for-all 3 '())) + (error? ; nonprocedure + (for-all 3 '() '())) (error? ; nonprocedure (for-all 3 '(a b c))) (error? ; improper list diff --git a/s/cp0.ss b/s/cp0.ss index 95bf069107..c7b3acdfa9 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3619,14 +3619,18 @@ (cons `(call ,preinfo (ref #f ,p) ,(map (lambda (t*) (build-ref (car t*))) t**) ...) (g (map cdr t**))))))]) - (if (and map? (not (eq? ctxt 'effect))) - (build-primcall lvl 'list results) - (make-seq* ctxt results))) + (if (and map? (not (eq? (app-ctxt ctxt) 'effect))) + (if (null? results) + null-rec + (build-primcall lvl 'list results)) + (if (null? results) + void-rec + (make-seq* (app-ctxt ctxt) results)))) (non-result-exp (value-visit-operand! (car ls*)) (build-let (car t**) (car e**) (f (cdr t**) (cdr e**) (cdr ls*))))))]) (if (fx= lvl 2) - (make-seq ctxt + (make-seq (app-ctxt ctxt) `(if ,(build-primcall 2 'procedure? (list `(ref #f ,p))) ,void-rec ,(build-primcall 3 '$oops (list `(quote ,(if map? 'map 'for-each)) @@ -3642,11 +3646,7 @@ [else #f]))))) (define-inline 2 map [(?p ?ls . ?ls*) - (if (andmap null-rec? (cons ?ls ?ls*)) - (begin - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - null-rec) - (inline-lists ?p ?ls ?ls* 2 #t ctxt sc wd name moi))]) + (inline-lists ?p ?ls ?ls* 2 #t ctxt sc wd name moi)]) (define-inline 3 map [(?p ?ls . ?ls*) (cond @@ -3725,12 +3725,7 @@ (define-inline 2 for-each [(?p ?ls . ?ls*) - (cond - [(andmap null-rec? (cons ?ls ?ls*)) - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - void-rec] - [else - (inline-lists ?p ?ls ?ls* 2 #f ctxt sc wd name moi)])]) + (inline-lists ?p ?ls ?ls* 2 #f ctxt sc wd name moi)]) (define-inline 3 for-each [(?p ?ls . ?ls*) (cond From 59c87c8e9f61ea4d42a3f2983084bbdf42e5154b Mon Sep 17 00:00:00 2001 From: dyb Date: Sun, 18 Feb 2018 20:41:15 -0500 Subject: [PATCH 2/2] minor corrections to 4.ms; updated root-experr-compile-{0,2}-f-f-f original commit: 86591f9dd45f36aa0e7d320d2286ffdb1b49076e --- mats/4.ms | 8 ++++---- mats/root-experr-compile-0-f-f-f | 17 +++++++++++++++++ mats/root-experr-compile-2-f-f-f | 20 ++++++++++++++++++++ 3 files changed, 41 insertions(+), 4 deletions(-) diff --git a/mats/4.ms b/mats/4.ms index 3177b42044..3d531e227f 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -1425,9 +1425,9 @@ (procedure? (lambda (x) (fold-left x))) (procedure? (lambda (x) (fold-left x y))) (error? ; nonprocedure - (for-left 3 0 '())) + (fold-left 3 0 '())) (error? ; nonprocedure - (for-left 3 0 '() '())) + (fold-left 3 0 '() '())) (error? ; nonprocedure (fold-left 3 0 '(a b c))) (error? ; improper list @@ -1553,9 +1553,9 @@ (procedure? (lambda (x) (fold-right x))) (procedure? (lambda (x) (fold-right x y))) (error? ; nonprocedure - (for-right 3 0 '())) + (fold-right 3 0 '())) (error? ; nonprocedure - (for-right 3 0 '() '())) + (fold-right 3 0 '() '())) (error? ; nonprocedure (fold-right 3 0 '(a b c))) (error? ; improper list diff --git a/mats/root-experr-compile-0-f-f-f b/mats/root-experr-compile-0-f-f-f index d39d411c69..472415f8e6 100644 --- a/mats/root-experr-compile-0-f-f-f +++ b/mats/root-experr-compile-0-f-f-f @@ -269,6 +269,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #