Skip to content

Commit 79c87b7

Browse files
gus-massagus-massa
authored
Rewrite build-let in cptypes (#952)
Internal redesign of build-let to make it easier to use.
1 parent 9d7a0e7 commit 79c87b7

File tree

1 file changed

+43
-48
lines changed

1 file changed

+43
-48
lines changed

‎s/cptypes.ss‎

Lines changed: 43 additions & 48 deletions
Original file line numberDiff line numberDiff line change
@@ -326,10 +326,13 @@ Notes:
326326
(loop rev-rbefore* (cons v rev-rvar*) (cons (car e*) rev-re*) (cons (build-ref v) rev-rref*)
327327
(cdr e*) (cdr r*)))])))
328328

329-
(define (build-let var* e* body)
330-
(if (null? var*)
331-
body
332-
`(call ,(make-preinfo-call) ,(build-lambda var* body) ,e* ...)))
329+
(define (build-let ctxt e* r* body-k)
330+
(let-values ([(before* var* val* e*) (prepare-let e* r*)])
331+
(let ([body (body-k e*)])
332+
(make-seq ctxt (make-1seq* 'effect before*)
333+
(if (null? var*)
334+
body
335+
`(call ,(make-preinfo-call) ,(build-lambda var* body) ,val* ...))))))
333336

334337
(define build-lambda
335338
(case-lambda
@@ -351,6 +354,14 @@ Notes:
351354
(nanopass-case (Lsrc Expr) v
352355
[(ref ,maybe-src ,x) (and (not (prelex-assigned x)) x)]
353356
[else #f])))
357+
358+
(define (filter/head+rest pred? l)
359+
; (filter/head+rest odd? '(1 3 2 5 4 6))
360+
; ==> (values '(1 3) '(2 5 4 6))
361+
(let loop ([l l] [rev-head '()])
362+
(if (or (null? l) (not (pred? (car l))))
363+
(values (reverse rev-head) l)
364+
(loop (cdr l) (cons (car l) rev-head)))))
354365
)
355366

356367
(module (pred-env-empty pred-env-bottom
@@ -1006,47 +1017,31 @@ Notes:
10061017
)
10071018

10081019
(let ()
1009-
(define (countmap f l*)
1010-
(fold-left (lambda (x l) (if (f l) (+ 1 x) x)) 0 l*))
1011-
10121020
(define-syntax define-specialize/bitwise
10131021
(syntax-rules ()
1014-
[(_ lev prim fxprim retfnexpr)
1022+
[(_ lev prim fxprim retfnexpr?)
10151023
(define-specialize lev prim
10161024
; Arity is checked before calling this handle.
1017-
[e* (let ([retfn (lambda (r*) (if (retfnexpr r*) 'fixnum 'exact-integer))]
1018-
[r* (get-type e*)])
1019-
(cond
1020-
[(ormap (lambda (r) (predicate-disjoint? r 'fixnum)) r*)
1021-
; some of the arguments can be bignums
1022-
(values `(call ,preinfo ,pr ,e* (... ...))
1023-
(retfn r*) ntypes #f #f)]
1024-
[else
1025-
(let ([count (countmap (lambda (r) (not (predicate-implies? r 'fixnum))) r*)])
1026-
(cond
1027-
[(fx= count 0)
1028-
(let ([fxpr (lookup-primref 3 'fxprim)])
1029-
(values `(call ,preinfo ,fxpr ,e* (... ...))
1030-
'fixnum ntypes #f #f))]
1031-
[(fx> count 1)
1032-
(values `(call ,preinfo ,pr ,e* (... ...))
1033-
(retfn r*) ntypes #f #f)]
1034-
[else
1035-
(let ([fxpr (lookup-primref 3 'fxprim)])
1036-
(let-values ([(before* var* e* ref*) (prepare-let e* r*)])
1037-
(let ([test (let loop ([r* r*] [ref* ref*])
1038-
; find the one that may not be a fixnum
1039-
(cond
1040-
[(predicate-implies? (car r*) 'fixnum)
1041-
(loop (cdr r*) (cdr ref*))]
1042-
[else
1043-
`(call ,(make-preinfo-call) ,(lookup-primref 2 'fixnum?) ,(car ref*))]))])
1044-
(values (make-seq ctxt (make-1seq* 'effect before*)
1045-
(build-let var* e*
1046-
`(if ,test
1047-
(call ,(make-preinfo-call) ,fxpr ,ref* (... ...))
1048-
(call ,preinfo ,pr ,ref* (... ...)))))
1049-
(retfn r*) ntypes #f #f))))]))]))])]))
1025+
[e* (let*-values ([(r*) (get-type e*)]
1026+
[(r-head* r-rest*) (filter/head+rest (lambda (r) (predicate-implies? r 'fixnum)) r*)]
1027+
[(all-fixnum) (null? r-rest*)]
1028+
[(ret) (if (or all-fixnum (retfnexpr? r*))
1029+
'fixnum
1030+
'exact-integer)])
1031+
(values (cond
1032+
[(or all-fixnum
1033+
(predicate-disjoint? (car r-rest*) 'fixnum) ; this arguments may be a bignum
1034+
(not (andmap (lambda (r) (predicate-implies? r 'fixnum)) (cdr r-rest*))))
1035+
(let ([pr (if all-fixnum (lookup-primref 3 'fxprim) pr)])
1036+
`(call ,preinfo ,pr ,e* (... ...)))]
1037+
[else
1038+
(build-let ctxt e* r*
1039+
(lambda (e*)
1040+
(let ([bad-e (list-ref e* (length r-head*))])
1041+
`(if (call ,(make-preinfo-call) ,(lookup-primref 2 'fixnum?) ,bad-e)
1042+
(call ,(make-preinfo-call) ,(lookup-primref 3 'fxprim) ,e* (... ...))
1043+
(call ,preinfo ,pr ,e* (... ...))))))])
1044+
ret ntypes #f #f))])]))
10501045

10511046
(define-specialize/bitwise 2 bitwise-and
10521047
fxand
@@ -1172,13 +1167,13 @@ Notes:
11721167
[(n) (let ([r (get-type n)])
11731168
(cond
11741169
[(predicate-implies? r 'fixnum)
1175-
(let-values ([(before* var* n* ref*) (prepare-let (list n) (list r))])
1176-
(values (make-seq ctxt (make-1seq* 'effect before*)
1177-
(build-let var* n*
1178-
`(if (call ,(make-preinfo-call) ,(lookup-primref 3 'fx=) ,(car ref*) (quote ,(constant most-negative-fixnum)))
1179-
,(make-seq ctxt `(pariah) `(quote ,(- (constant most-negative-fixnum))))
1180-
(call ,preinfo ,(lookup-primref 3 'fxabs) ,(car ref*)))))
1181-
'exact-integer ntypes #f #f))]
1170+
(values (build-let ctxt (list n) (list r)
1171+
(lambda (n*)
1172+
(let ([n (car n*)])
1173+
`(if (call ,(make-preinfo-call) ,(lookup-primref 3 'fx=) ,n (quote ,(constant most-negative-fixnum)))
1174+
,(make-seq ctxt `(pariah) `(quote ,(- (constant most-negative-fixnum))))
1175+
(call ,preinfo ,(lookup-primref 3 'fxabs) ,n)))))
1176+
'exact-integer ntypes #f #f)]
11821177
[(predicate-implies? r 'bignum)
11831178
(values `(call ,preinfo ,pr ,n)
11841179
'bignum ntypes #f #f)]

0 commit comments

Comments
 (0)