Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-17 01:37:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Optimize calls to (list)

Browse source
This commit is contained in:
Justin Ethier 2018-06-19 18:06:18 -04:00
parent f2704eb5e4
commit b611520274
2 changed files with 30 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
include/cyclone/types.h
View file

@ -1069,18 +1069,18 @@ typedef pair_type *pair;
#define make_list_2(l, a1, a2) \ #define make_list_2(l, a1, a2) \
make_pair(l##__2, a2, NULL); \ make_pair(l##__2, a2, NULL); \
make_pair(l, a1, l##__2); make_pair(l, a1, &l##__2);
#define make_list_3(l, a1, a2, a3) \ #define make_list_3(l, a1, a2, a3) \
make_pair(l##__3, a3, NULL); \ make_pair(l##__3, a3, NULL); \
make_pair(l##__2, a2, l##__3); \ make_pair(l##__2, a2, &l##__3); \
make_pair(l, a1, l##__2); make_pair(l, a1, &l##__2);
#define make_list_4(l, a1, a2, a3, a4) \ #define make_list_4(l, a1, a2, a3, a4) \
make_pair(l##__4, a4, NULL); \ make_pair(l##__4, a4, NULL); \
make_pair(l##__3, a3, l##__4); \ make_pair(l##__3, a3, &l##__4); \
make_pair(l##__2, a2, l##__3); \ make_pair(l##__2, a2, &l##__3); \
make_pair(l, a1, l##__2); make_pair(l, a1, &l##__2);
/** /**
* Create a pair with a single value. * Create a pair with a single value.

31
scheme/cyclone/transforms.sld
View file

@ -913,21 +913,30 @@
(append a-lookup defines-a-lookup renamed)) (append a-lookup defines-a-lookup renamed))
(map (lambda (p) (cdr p)) defines-a-lookup))))) (map (lambda (p) (cdr p)) defines-a-lookup)))))
((app? ast) ((app? ast)
(let ((regular-case
(lambda ()
;; Regular case, alpha convert everything
(map (lambda (a) (convert a renamed)) ast))))
(cond (cond
;; If identifier is renamed it is not a special case
((assoc (car ast) renamed)
(regular-case))
;; Special case, convert these to primitives if possible ;; Special case, convert these to primitives if possible
((and (eq? (car ast) 'member) ((and (eq? (car ast) 'member) (= (length ast) 3))
(not (assoc (car ast) renamed)) (cons 'Cyc-fast-member (map (lambda (a) (convert a renamed)) (cdr ast))))
(= (length ast) 3)) ((and (eq? (car ast) 'assoc) (= (length ast) 3))
(cons 'Cyc-fast-member (cons 'Cyc-fast-assoc (map (lambda (a) (convert a renamed)) (cdr ast))))
(map (lambda (a) (convert a renamed)) (cdr ast)))) ((and (eq? (car ast) 'list) (= (length ast) 2))
((and (eq? (car ast) 'assoc) (cons 'Cyc-fast-list-1 (map (lambda (a) (convert a renamed)) (cdr ast))))
(not (assoc (car ast) renamed)) ((and (eq? (car ast) 'list) (= (length ast) 3))
(= (length ast) 3)) (cons 'Cyc-fast-list-2 (map (lambda (a) (convert a renamed)) (cdr ast))))
(cons 'Cyc-fast-assoc ((and (eq? (car ast) 'list) (= (length ast) 4))
(map (lambda (a) (convert a renamed)) (cdr ast)))) (cons 'Cyc-fast-list-3 (map (lambda (a) (convert a renamed)) (cdr ast))))
((and (eq? (car ast) 'list) (= (length ast) 5))
(cons 'Cyc-fast-list-4 (map (lambda (a) (convert a renamed)) (cdr ast))))
;; Regular case, alpha convert everything ;; Regular case, alpha convert everything
(else (else
(map (lambda (a) (convert a renamed)) ast)))) (regular-case)))))
(else (else
(error "unhandled expression: " ast)))) (error "unhandled expression: " ast))))