mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-22 04:30:19 +02:00
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.
This commit is contained in:
parent
5af166bda2
commit
c11f46afe1
3 changed files with 14 additions and 4 deletions
|
@ -312,7 +312,12 @@
|
||||||
(error "Unknown instruction:" inst))
|
(error "Unknown instruction:" inst))
|
||||||
(let ((pops (instruction-pops inst)))
|
(let ((pops (instruction-pops inst)))
|
||||||
(cond ((< pops 0)
|
(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)
|
((= pops nargs)
|
||||||
(emit-code `((,inst))))
|
(emit-code `((,inst))))
|
||||||
(else
|
(else
|
||||||
|
|
|
@ -79,7 +79,9 @@
|
||||||
((set-car! . 2) . set-car!)
|
((set-car! . 2) . set-car!)
|
||||||
((set-cdr! . 2) . set-cdr!)
|
((set-cdr! . 2) . set-cdr!)
|
||||||
((null? . 1) . null?)
|
((null? . 1) . null?)
|
||||||
((list? . 1) . list?)))
|
((list? . 1) . list?)
|
||||||
|
(list . list)
|
||||||
|
(vector . vector)))
|
||||||
|
|
||||||
(define (make-label) (gensym ":L"))
|
(define (make-label) (gensym ":L"))
|
||||||
|
|
||||||
|
@ -254,8 +256,9 @@
|
||||||
(emit-code src (make-glil-call 'drop 1)))))
|
(emit-code src (make-glil-call 'drop 1)))))
|
||||||
|
|
||||||
((and (primitive-ref? proc)
|
((and (primitive-ref? proc)
|
||||||
(hash-ref *primcall-ops*
|
(or (hash-ref *primcall-ops*
|
||||||
(cons (primitive-ref-name proc) (length args))))
|
(cons (primitive-ref-name proc) (length args)))
|
||||||
|
(hash-ref *primcall-ops* (primitive-ref-name proc))))
|
||||||
=> (lambda (op)
|
=> (lambda (op)
|
||||||
(for-each comp-push args)
|
(for-each comp-push args)
|
||||||
(emit-code src (make-glil-call op (length args)))
|
(emit-code src (make-glil-call op (length args)))
|
||||||
|
|
|
@ -53,6 +53,8 @@
|
||||||
not
|
not
|
||||||
pair? null? list? acons cons cons*
|
pair? null? list? acons cons cons*
|
||||||
|
|
||||||
|
list vector
|
||||||
|
|
||||||
car cdr
|
car cdr
|
||||||
set-car! set-cdr!
|
set-car! set-cdr!
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue