mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +02:00
Code Activity

special cases for more types of known applications

Browse source 
* module/language/tree-il/compile-glil.scm (flatten): Handle a number of
  interesting applications, and fix a bug for calls in `drop' contexts.

* module/language/tree-il/inline.scm: Define expanders for apply,
  call-with-values, call-with-current-continuation, and values.
This commit is contained in:
Andy Wingo 2009-05-18 01:08:34 +02:00
parent 112edbaea3
commit dce042f1f7
2 changed files with 83 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

78
module/language/tree-il/compile-glil.scm
View file

@ -30,10 +30,6 @@
;;; TODO:
;;
;; * ([@]apply f args) -> goto/apply or similar
;; * ([@]apply values args) -> goto/values or similar
;; * ([@]call-with-values prod cons) ...
;; * ([@]call-with-current-continuation prod cons) ...
;; call-with-values -> mv-bind
;; compile-time-environment
;; GOOPS' @slot-ref, @slot-set
@ -178,7 +174,71 @@
(lp (cdr exps))))))
((<application> src proc args)
;; FIXME: need a better pattern-matcher here
(cond
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@apply)
(>= (length args) 2))
(let ((proc (car args))
(args (cdr args)))
(cond
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
(not (eq? context 'push)))
;; tail: (lambda () (apply values '(1 2)))
;; drop: (lambda () (apply values '(1 2)) 3)
;; push: (lambda () (list (apply values '(10 12)) 1))
(case context
((drop) (for-each comp-drop args))
((tail)
(for-each comp-push args)
(emit-code src (make-glil-call 'return/values* (length args))))))
(else
(comp-push proc)
(for-each comp-push args)
(case context
((drop) (emit-code src (make-glil-call 'apply (length args)))
(emit-code src (make-glil-call 'drop 1)))
((tail) (emit-code src (make-glil-call 'goto/apply (length args))))
((push) (emit-code src (make-glil-call 'apply (length args)))))))))
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-values)
(= (length args) 2))
;; CONSUMER
;; PRODUCER
;; (mv-call MV)
;; ([tail]-call 1)
;; goto POST
;; MV: [tail-]call/nargs
;; POST: (maybe-drop)
(let ((MV (make-label)) (POST (make-label))
(producer (car args)) (consumer (cadr args)))
(comp-push consumer)
(comp-push producer)
(emit-code src (make-glil-mv-call 0 MV))
(case context
((tail) (emit-code src (make-glil-call 'goto/args 1)))
(else (emit-code src (make-glil-call 'call 1))
(emit-branch #f 'br POST)))
(emit-label MV)
(case context
((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
(else (emit-code src (make-glil-call 'call/nargs 0))
(emit-label POST)
(if (eq? context 'drop)
(emit-code #f (make-glil-call 'drop 1)))))))
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-current-continuation)
(= (length args 1)))
(comp-push (car args))
(case context
((tail) (emit-code src (make-glil-call 'goto/cc 1)))
((push) (emit-code src (make-glil-call 'call/cc 1)))
((drop) (emit-code src (make-glil-call 'call/cc 1))
(emit-code src (make-glil-call 'drop 1)))))
((and (primitive-ref? proc)
(hash-ref *primcall-ops*
(cons (primitive-ref-name proc) (length args))))
@ -191,10 +251,12 @@
(else
(comp-push proc)
(for-each comp-push args)
(emit-code src (make-glil-call (case context
((tail) 'goto/args)
(else 'call))
(length args))))))
(let ((len (length args)))
(case context
((tail) (emit-code src (make-glil-call 'goto/args len)))
((push) (emit-code src (make-glil-call 'call len)))
((drop) (emit-code src (make-glil-call 'call len))
(emit-code src (make-glil-call 'drop 1))))))))
((<conditional> src test then else)
;; TEST

15
module/language/tree-il/inline.scm
View file

@ -135,5 +135,16 @@
(x y) (cons x y)
(x y . rest) (cons x (cons* y . rest)))
(define-primitive-expander acons
(x y z) (cons (cons x y) z))
(define-primitive-expander acons (x y z)
(cons (cons x y) z))
(define-primitive-expander apply (f . args)
(@apply f . args))
(define-primitive-expander call-with-values (producer consumer)
(@call-with-values producer consumer))
(define-primitive-expander call-with-current-continuation (proc)
(@call-with-current-continuation proc))
(define-primitive-expander values (x) x)