From: Andy Wingo <wingo@pobox.com>
Date: Wed, 20 May 2009 11:33:44 +0000 (+0200)
Subject: compile `list' and `vector' to their associated opcodes
X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/c11f46afe113f50e34af33ad3055b3da66e4b71f

compile `list' and `vector' to their associated opcodes

* module/language/glil/compile-assembly.scm (glil->assembly): Check the
  length when emitting calls to variable-argument stack instructions.
  Allow two-byte lengths -- allows e.g. calls to `list' with more than
  256 arguments.

* module/language/tree-il/compile-glil.scm: Add primcall associations for
  `list' and `vector', with any number of arguments. Necessary because
  syncase's quasiquote expansions will produce calls to `list' with many
  arguments.

* module/language/tree-il/optimize.scm (*interesting-primitive-names*):
  Add `list' and `vector' to the set of primitives to resolve.
---

diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index 73b2cd132..4c92e0f5a 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -312,7 +312,12 @@
          (error "Unknown instruction:" inst))
      (let ((pops (instruction-pops inst)))
        (cond ((< pops 0)
-              (emit-code `((,inst ,nargs))))
+              (case (instruction-length inst)
+                ((1) (emit-code `((,inst ,nargs))))
+                ((2) (emit-code `((,inst ,(quotient nargs 256)
+                                         ,(modulo nargs 256)))))
+                (else (error "Unknown length for variable-arg instruction:"
+                             inst (instruction-length inst)))))
              ((= pops nargs)
               (emit-code `((,inst))))
              (else
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 78e2d1e94..17592d275 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -79,7 +79,9 @@
    ((set-car! . 2) . set-car!)
    ((set-cdr! . 2) . set-cdr!)
    ((null? . 1) . null?)
-   ((list? . 1) . list?)))
+   ((list? . 1) . list?)
+   (list . list)
+   (vector . vector)))
 
 (define (make-label) (gensym ":L"))
 
@@ -254,8 +256,9 @@
                    (emit-code src (make-glil-call 'drop 1)))))
 
         ((and (primitive-ref? proc)
-              (hash-ref *primcall-ops*
-                        (cons (primitive-ref-name proc) (length args))))
+              (or (hash-ref *primcall-ops*
+                            (cons (primitive-ref-name proc) (length args)))
+                  (hash-ref *primcall-ops* (primitive-ref-name proc))))
          => (lambda (op)
               (for-each comp-push args)
               (emit-code src (make-glil-call op (length args)))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 03193b256..57755ea5e 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -53,6 +53,8 @@
     not
     pair? null? list? acons cons cons*
 
+    list vector
+
     car cdr
     set-car! set-cdr!