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

inline calls to some primitives

Browse source 
* module/system/base/pmatch.scm: Wrap consequents in (let () ) instead of
  (begin ) so that they can have local definitions.

* module/language/tree-il/compile-glil.scm: Inline some calls to
  primitives.
This commit is contained in:
Andy Wingo 2009-05-17 23:24:26 +02:00
parent 1eec95f8de
commit 112edbaea3
2 changed files with 48 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -30,7 +30,6 @@
;;; TODO:
;;
;; * (delay x) -> (make-promise (lambda () x))
;; * ([@]apply f args) -> goto/apply or similar
;; * ([@]apply values args) -> goto/values or similar
;; * ([@]call-with-values prod cons) ...
@ -39,7 +38,6 @@
;; compile-time-environment
;; GOOPS' @slot-ref, @slot-set
;; basic degenerate-case reduction
;; vm op "inlining"
;; allocation:
;; sym -> (local . index) | (heap level . index)
@ -55,6 +53,34 @@
(define *primcall-ops* (make-hash-table))
(for-each
(lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
'(((eq? . 2) . eq?)
((eqv? . 2) . eqv?)
((equal? . 2) . equal?)
((= . 2) . ee?)
((< . 2) . lt?)
((> . 2) . gt?)
((<= . 2) . le?)
((>= . 2) . ge?)
((+ . 2) . add)
((- . 2) . sub)
((* . 2) . mul)
((/ . 2) . div)
((quotient . 2) . quo)
((remainder . 2) . rem)
((modulo . 2) . mod)
((not . 1) . not)
((pair? . 1) . pair?)
((cons . 2) . cons)
((car . 1) . car)
((cdr . 1) . cdr)
((set-car! . 2) . set-car!)
((set-cdr! . 2) . set-cdr!)
((null? . 1) . null?)
((list? . 1) . list?)))
(define (make-label) (gensym ":L"))
(define (vars->bind-list ids vars allocation)
@ -152,12 +178,23 @@
(lp (cdr exps))))))
((<application> src proc args)
(comp-push proc)
(for-each comp-push args)
(emit-code src (make-glil-call (case context
((tail) 'goto/args)
(else 'call))
(length args))))
(cond
((and (primitive-ref? proc)
(hash-ref *primcall-ops*
(cons (primitive-ref-name proc) (length args))))
=> (lambda (op)
(for-each comp-push args)
(emit-code src (make-glil-call op (length args)))
(case context
((tail) (emit-code #f (make-glil-call 'return 1)))
((drop) (emit-code #f (make-glil-call 'drop 1))))))
(else
(comp-push proc)
(for-each comp-push args)
(emit-code src (make-glil-call (case context
((tail) 'goto/args)
(else 'call))
(length args))))))
((<conditional> src test then else)
;; TEST

6
module/system/base/pmatch.scm
View file

@ -16,15 +16,15 @@
(let ((v (op arg ...)))
(pmatch v cs ...)))
((_ v) (if #f #f))
((_ v (else e0 e ...)) (begin e0 e ...))
((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat
(if (and g ...) (begin e0 e ...) (fk))
(if (and g ...) (let () e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat (begin e0 e ...) (fk))))))
(ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat
(syntax-rules (_ quote unquote)