mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

support calls and tail-calls with more than 255 formals

Browse source 
* module/language/tree-il/compile-glil.scm (flatten-lambda-case):
  Support calls and tail-calls with more than 255 formals.

* test-suite/tests/tree-il.test ("many args"): Add a test.
This commit is contained in:
Andy Wingo 2013-03-07 13:59:18 +01:00
parent 8d48877d2c
commit d0ecf8eb9e
2 changed files with 31 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler ;;; TREE-IL -> GLIL compiler
;; Copyright (C) 2001,2008,2009,2010,2011,2012 Free Software Foundation, Inc. ;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -527,9 +527,20 @@
(for-each comp-push args) (for-each comp-push args)
(let ((len (length args))) (let ((len (length args)))
(case context (case context
((tail) (emit-code src (make-glil-call 'tail-call len))) ((tail) (if (<= len #xff)
((push) (emit-code src (make-glil-call 'call len)) (emit-code src (make-glil-call 'tail-call len))
(begin
(comp-push (make-const #f len))
(emit-code src (make-glil-call 'tail-call/nargs 0)))))
((push) (if (<= len #xff)
(emit-code src (make-glil-call 'call len))
(begin
(comp-push (make-const #f len))
(emit-code src (make-glil-call 'call/nargs 0))))
(maybe-emit-return)) (maybe-emit-return))
;; FIXME: mv-call doesn't have a /nargs variant, so it is
;; limited to 255 args. Can work around it with a
;; trampoline and tail-call/nargs, but it's not so nice.
((vals) (emit-code src (make-glil-mv-call len MVRA)) ((vals) (emit-code src (make-glil-mv-call len MVRA))
(maybe-emit-return)) (maybe-emit-return))
((drop) (let ((MV (make-label)) (POST (make-label))) ((drop) (let ((MV (make-label)) (POST (make-label)))

18
test-suite/tests/tree-il.test
View file

@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;; ;;;;
;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -701,6 +701,22 @@
;; reduce the entire thing to #t. ;; reduce the entire thing to #t.
#:opts '(#:partial-eval? #f))))) #:opts '(#:partial-eval? #f)))))
(define (sum . args)
(apply + args))
(with-test-prefix "many args"
(pass-if "call with > 256 args"
(equal? (compile `(1+ (sum ,@(iota 1000)))
#:env (current-module))
(1+ (apply sum (iota 1000)))))
(pass-if "tail call with > 256 args"
(equal? (compile `(sum ,@(iota 1000))
#:env (current-module))
(apply sum (iota 1000)))))
(with-test-prefix "tree-il-fold" (with-test-prefix "tree-il-fold"