suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Remove special case for (#2%map p '()) in cp0

Browse Source 
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
This commit is contained in:
Gustavo Massaccesi 2018-02-09 10:21:00 -03:00
parent af60b1c8df
commit 4991067ed7
3 changed files with 55 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
LOG
View File

@ -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

41
mats/4.ms
View File

@ -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

25
s/cp0.ss
View File

@ -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