mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-26 21:20:30 +02:00
Code Activity

add <primcall> to tree-il

Browse source 
* libguile/expand.c:
* libguile/expand.h (SCM_EXPANDED_PRIMCALL_TYPE_NAME):
  (SCM_EXPANDED_PRIMCALL_FIELD_NAMES):
  (SCM_EXPANDED_PRIMCALL_SRC):
  (SCM_EXPANDED_PRIMCALL_NAME):
  (SCM_EXPANDED_PRIMCALL_ARGS):
  (SCM_MAKE_EXPANDED_PRIMCALL): Add "primcall" Tree-IL type.

* doc/ref/compiler.texi (Tree-IL): Update docs.

* libguile/memoize.c (memoize): Memoizer for primcalls.

* module/ice-9/psyntax.scm: Build primcalls, sometimes.  Also change
  build-primref to just make a primitive-ref.

* module/language/tree-il.scm: Add primcall to the exports, parsers,
  serializers, etc.

* module/language/tree-il/analyze.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/fix-letrec.scm:
* module/language/tree-il/inline.scm:
* module/language/tree-il/primitives.scm:
* module/language/elisp/compile-tree-il.scm: Add primcall support.

* test-suite/tests/tree-il.test: Use primcalls sometimes.
This commit is contained in:
Andy Wingo 2011-06-02 17:41:45 +02:00
parent 7081d4f981
commit a881a4ae3b
14 changed files with 7186 additions and 7090 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -47,44 +47,36 @@
(else x)))
(else x)))
((<call> src proc args)
(record-case proc
;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
((<primitive-ref> name)
(case name
((memq memv)
(pmatch args
((,k ,l) (guard (const? l) (list? (const-exp l)))
(cond
((null? (const-exp l))
(make-const #f #f))
((const? k)
(make-const #f (->bool ((case name
((memq) memq)
((memv) memv)
(else (error "unexpected member func" name)))
(const-exp k) (const-exp l)))))
(else
(let lp ((elts (const-exp l)))
(let ((test (make-call
#f
(make-primitive-ref #f (case name
((memq) 'eq?)
((memv) 'eqv?)
(else (error "what"))))
(list k (make-const #f (car elts))))))
(if (null? (cdr elts))
test
(make-conditional
src
test
(make-const #f #t)
(lp (cdr elts)))))))))
(else x)))
(else x)))
((<primcall> src name args)
(pmatch (cons name args)
((,member ,k ,l) (guard (and (memq member '(memq memv))
(const? k)
(list? (const-exp l))))
(cond
((null? (const-exp l))
(make-const #f #f))
((const? k)
(make-const #f (->bool ((case member
((memq) memq)
((memv) memv)
(else (error "what" member)))
(const-exp k) (const-exp l)))))
(else
(let lp ((elts (const-exp l)))
(let ((test (make-primcall
#f
(case member
((memq) 'eq?)
((memv) 'eqv?)
(else (error "what" member)))
(list k (make-const #f (car elts))))))
(if (null? (cdr elts))
test
(make-conditional
src
test
(make-const #f #t)
(lp (cdr elts)))))))))
(else x)))
((<lambda> meta body)
@ -114,34 +106,29 @@
(or (inline1 x) x))
(lp alternate)))))))
((<primitive-ref> name)
(case name
((@call-with-values)
(pmatch args
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar)
;;
;; Note that this is a singly-binding form of let-values.
;; Also note that Scheme's let-values expands into
;; call-with-values, then here we reduce it to tree-il's
;; let-values.
((,producer ,consumer)
(guard (lambda? consumer)
(lambda-case? (lambda-body consumer))
(not (lambda-case-opt (lambda-body consumer)))
(not (lambda-case-kw (lambda-body consumer)))
(not (lambda-case-alternate (lambda-body consumer))))
(make-let-values
src
(let ((x (make-call src producer '())))
(or (inline1 x) x))
(lambda-body consumer)))
(else #f)))
(else #f)))
(else #f)))
((<primcall> src name args)
(pmatch (cons name args)
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar)
;;
;; Note that this is a singly-binding form of let-values. Also
;; note that Scheme's let-values expands into call-with-values,
;; then here we reduce it to tree-il's let-values.
((@call-with-values ,producer ,consumer)
(guard (lambda? consumer)
(lambda-case? (lambda-body consumer))
(not (lambda-case-opt (lambda-body consumer)))
(not (lambda-case-kw (lambda-body consumer)))
(not (lambda-case-alternate (lambda-body consumer))))
(make-let-values
src
(let ((x (make-call src producer '())))
(or (inline1 x) x))
(lambda-body consumer)))
(else #f)))
((<conditional> test consequent alternate)
(let ((btest (boolean-value test)))
(or (record-case btest
@ -178,10 +165,9 @@
(and (not opt) (not kw) rest (not alternate)
(record-case body
((<call> proc args)
((<primcall> name args)
;; (lambda args (apply (lambda ...) args)) => (lambda ...)
(and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@apply)
(and (eq? name '@apply)
(pair? args)
(lambda? (car args))
(args-compatible? (cdr args) gensyms)