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

First step towards emitting new instructions: "j" instead of "br"

Browse source 
* module/language/cps/compile-bytecode.scm (compile-function): Emit "j"
  instructions instead of "br".
This commit is contained in:
Andy Wingo 2017-10-25 16:45:45 +02:00
parent 258c59b4cc
commit 3d848f22f8
1 changed files with 7 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

14
module/language/cps/compile-bytecode.scm
View file

@ -289,7 +289,7 @@
(proc-slot (lookup-call-proc-slot label allocation))) (proc-slot (lookup-call-proc-slot label allocation)))
(emit-prompt asm (from-sp (slot tag)) escape? proc-slot (emit-prompt asm (from-sp (slot tag)) escape? proc-slot
receive-args) receive-args)
(emit-br asm k) (emit-j asm k)
(emit-label asm receive-args) (emit-label asm receive-args)
(unless (and rest (zero? nreq)) (unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq)) (emit-receive-values asm proc-slot (->bool rest) nreq))
@ -302,7 +302,7 @@
((src . dst) (emit-fmov asm dst src))) ((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves handler allocation)) (lookup-parallel-moves handler allocation))
(emit-reset-frame asm frame-size) (emit-reset-frame asm frame-size)
(emit-br asm (forward-label khandler-body)))))) (emit-j asm (forward-label khandler-body))))))
(($ $primcall 'cache-current-module! (sym scope)) (($ $primcall 'cache-current-module! (sym scope))
(emit-cache-current-module! asm (from-sp (slot sym)) (constant scope))) (emit-cache-current-module! asm (from-sp (slot sym)) (constant scope)))
(($ $primcall 'free-set! (closure idx value)) (($ $primcall 'free-set! (closure idx value))
@ -403,7 +403,7 @@
(else (else
(let ((invert? (not (prefer-true?)))) (let ((invert? (not (prefer-true?))))
(op asm (from-sp (slot sym)) invert? (if invert? kf kt)) (op asm (from-sp (slot sym)) invert? (if invert? kf kt))
(emit-br asm (if invert? kt kf)))))) (emit-j asm (if invert? kt kf))))))
(define (binary op a b) (define (binary op a b)
(cond (cond
((eq? kt next-label) ((eq? kt next-label)
@ -414,7 +414,7 @@
(let ((invert? (not (prefer-true?)))) (let ((invert? (not (prefer-true?))))
(op asm (from-sp (slot a)) (from-sp (slot b)) invert? (op asm (from-sp (slot a)) (from-sp (slot b)) invert?
(if invert? kf kt)) (if invert? kf kt))
(emit-br asm (if invert? kt kf)))))) (emit-j asm (if invert? kt kf))))))
(match exp (match exp
(($ $values (sym)) (unary emit-br-if-true sym)) (($ $values (sym)) (unary emit-br-if-true sym))
(($ $primcall 'null? (a)) (unary emit-br-if-null a)) (($ $primcall 'null? (a)) (unary emit-br-if-null a))
@ -505,7 +505,7 @@
(fallthrough? (= forwarded-k (skip-elided-conts (1+ label))))) (fallthrough? (= forwarded-k (skip-elided-conts (1+ label)))))
(define (maybe-emit-jump) (define (maybe-emit-jump)
(unless fallthrough? (unless fallthrough?
(emit-br asm forwarded-k))) (emit-j asm forwarded-k)))
(match (intmap-ref cps k) (match (intmap-ref cps k)
(($ $ktail) (($ $ktail)
(compile-tail label exp)) (compile-tail label exp))
@ -534,7 +534,7 @@
(fallthrough? (and fallthrough? (fallthrough? (and fallthrough?
(= kargs (skip-elided-conts (1+ k)))))) (= kargs (skip-elided-conts (1+ k))))))
(unless fallthrough? (unless fallthrough?
(emit-br asm kargs))))))) (emit-j asm kargs)))))))
(define (compile-cont label cont) (define (compile-cont label cont)
(match cont (match cont
@ -561,7 +561,7 @@
;; contified into another clause. ;; contified into another clause.
(let ((body (forward-label body))) (let ((body (forward-label body)))
(unless (= body (skip-elided-conts (1+ label))) (unless (= body (skip-elided-conts (1+ label)))
(emit-br asm body))))) (emit-j asm body)))))
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars ($ $continue k src exp))
(emit-label asm label) (emit-label asm label)
(for-each (lambda (name var) (for-each (lambda (name var)