conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Cadr is now open-coded.

This commit is contained in:
Abdulaziz Ghuloum 2006-12-07 02:48:31 -05:00
parent 1487c5ed54
commit bd71be0d64
4 changed files with 59 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

38
lib/libcompile.ss
View File

@ -828,7 +828,7 @@
(for-each (for-each
(lambda (x) (lambda (x)
(let ([n (getprop x '*compiler-giveup-tally*)]) (let ([n (getprop x '*compiler-giveup-tally*)])
(when (>= n 40) (when (>= n 30)
(printf "~s ~s\n" n x)))) (printf "~s ~s\n" n x))))
giveup-list)) giveup-list))
(primitive-set! 'compiler-giveup-tally print-tally)) (primitive-set! 'compiler-giveup-tally print-tally))
@ -1055,6 +1055,18 @@
[(car) (car v)] [(car) (car v)]
[else (cdr v)])))))))) [else (cdr v)]))))))))
(giveup))] (giveup))]
[(cadr)
(or (and (fx= (length rand*) 1)
(let ([a (car rand*)])
(or (constant-value a
(lambda (v)
(and (pair? v)
(pair? (cdr v))
(mk-seq a
(make-constant
(cadr v))))))
(make-primcall op rand*))))
(giveup))]
[(not null? pair? fixnum? vector? string? char? symbol? [(not null? pair? fixnum? vector? string? char? symbol?
eof-object?) eof-object?)
(or (and (fx= (length rand*) 1) (or (and (fx= (length rand*) 1)
@ -2041,7 +2053,7 @@
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))] [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(primcall op arg*) [(primcall op arg*)
(cond (cond
[(memq op '(not car cdr fxadd1 fxsub1)) ;;; SIMPLIFY [(memq op '(not car cdr cadr fxadd1 fxsub1)) ;;; SIMPLIFY
(make-primcall op (map Expr arg*))] (make-primcall op (map Expr arg*))]
[else [else
(simplify* arg* '() '() (simplify* arg* '() '()
@ -3364,6 +3376,20 @@
(jne (label SL_cdr_error)) (jne (label SL_cdr_error))
(movl (mem (fx- disp-cdr pair-tag) ebx) eax) (movl (mem (fx- disp-cdr pair-tag) ebx) eax)
ac)))))] ac)))))]
[(cadr)
(NonTail (car arg*)
(list*
(movl eax ebx)
(andl (int pair-mask) eax)
(cmpl (int pair-tag) eax)
(jne (label SL_cadr_error))
(movl (mem (fx- disp-cdr pair-tag) ebx) eax)
(movl eax ecx)
(andl (int pair-mask) eax)
(cmpl (int pair-tag) eax)
(jne (label SL_cadr_error))
(movl (mem (fx- disp-car pair-tag) ecx) eax)
ac))]
[(top-level-value) [(top-level-value)
(let ([x (car arg*)]) (let ([x (car arg*)])
(cond (cond
@ -4365,6 +4391,7 @@
(define SL_top_level_value_error (gensym "SL_top_level_value_error")) (define SL_top_level_value_error (gensym "SL_top_level_value_error"))
(define SL_car_error (gensym "SL_car_error")) (define SL_car_error (gensym "SL_car_error"))
(define SL_cdr_error (gensym "SL_cdr_error")) (define SL_cdr_error (gensym "SL_cdr_error"))
(define SL_cadr_error (gensym "SL_cadr_error"))
(define SL_invalid_args (gensym "SL_invalid_args")) (define SL_invalid_args (gensym "SL_invalid_args"))
(define SL_foreign_call (gensym "SL_foreign_call")) (define SL_foreign_call (gensym "SL_foreign_call"))
(define SL_continuation_code (gensym "SL_continuation_code")) (define SL_continuation_code (gensym "SL_continuation_code"))
@ -4404,7 +4431,12 @@
(movl (primref-loc 'cdr-error) cpr) (movl (primref-loc 'cdr-error) cpr)
(movl (int (argc-convention 1)) eax) (movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call)) (tail-indirect-cpr-call))
(list 0
(label SL_cadr_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'cadr-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(list 0 (list 0
(label SL_top_level_value_error) (label SL_top_level_value_error)
(movl ebx (mem (fx- 0 wordsize) fpr)) (movl ebx (mem (fx- 0 wordsize) fpr))

34
lib/libcxr.ss
View File

@ -1,13 +1,17 @@
(primitive-set! 'car (lambda (x) (car x)))
(primitive-set! 'cdr (lambda (x) (cdr x)))
(primitive-set! 'cadr (lambda (x) (cadr x)))
(let ([err (lambda (who x) (let ([err (lambda (who x)
(error who "invalid list structure ~s" x))]) (error who "invalid list structure ~s" x))])
(primitive-set! ;(primitive-set!
'car ; 'car
(lambda (orig) ; (lambda (orig)
(if (pair? orig) ($car orig) (err 'car orig)))) ; (if (pair? orig) ($car orig) (err 'car orig))))
(primitive-set! ;(primitive-set!
'cdr ; 'cdr
(lambda (orig) ; (lambda (orig)
(if (pair? orig) ($cdr orig) (err 'cdr orig)))) ; (if (pair? orig) ($cdr orig) (err 'cdr orig))))
(primitive-set! (primitive-set!
'caar 'caar
(lambda (orig) (lambda (orig)
@ -15,13 +19,13 @@
(let ([x ($car orig)]) (let ([x ($car orig)])
(if (pair? x) ($car x) (err 'caar orig))) (if (pair? x) ($car x) (err 'caar orig)))
(err 'caar orig)))) (err 'caar orig))))
(primitive-set! ;(primitive-set!
'cadr ; 'cadr
(lambda (orig) ; (lambda (orig)
(if (pair? orig) ; (if (pair? orig)
(let ([x ($cdr orig)]) ; (let ([x ($cdr orig)])
(if (pair? x) ($car x) (err 'cadr orig))) ; (if (pair? x) ($car x) (err 'cadr orig)))
(err 'cadr orig)))) ; (err 'cadr orig))))
(primitive-set! (primitive-set!
'cdar 'cdar
(lambda (orig) (lambda (orig)

5
lib/libhandlers.ss
View File

@ -55,3 +55,8 @@
(error 'fxsub1 "underflow") (error 'fxsub1 "underflow")
(error 'fxsub1 "~s is not a fixnum" x)))) (error 'fxsub1 "~s is not a fixnum" x))))
(primitive-set! 'cadr-error
(lambda (x)
(error 'cadr "invalid list structure in ~s" x)))