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

Heap type predicates preceded by heap-object?

Browse source 
* module/language/cps/compile-bytecode.scm (compile-function): Add
  support for heap-object? in test context.
* module/language/cps/primitives.scm (*immediate-predicates*):
  (*heap-type-predicates*, *comparisons*): New sets of predicates for
  which the VM has branching operations.
  (heap-type-predicate?): New predicate.
  (*branching-primcall-arities*): Make a hash table.
  (branching-primitive?, prim-arity): Adapt
  to *branching-primcall-arities* being a hash table.
* module/language/cps/type-fold.scm (heap-object?): Add folder.
* module/language/tree-il/compile-cps.scm (convert): Precede heap type
  checks with a heap-object? guard.
This commit is contained in:
Andy Wingo 2017-10-26 21:14:39 +02:00
parent 6dd30920eb
commit 1139c10e09
4 changed files with 150 additions and 52 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -404,6 +404,21 @@
(let ((invert? (not (prefer-true?))))
(op asm (from-sp (slot sym)) invert? (if invert? kf kt))
(emit-j asm (if invert? kt kf))))))
(define (emit-branch-for-test)
(cond
((eq? kt next-label)
(emit-jne asm kf))
((eq? kf next-label)
(emit-je asm kt))
((prefer-true?)
(emit-je asm kt)
(emit-j asm kf))
(else
(emit-jne asm kf)
(emit-j asm kt))))
(define (unary* op a)
(op asm (from-sp (slot a)))
(emit-branch-for-test))
(define (binary op a b)
(cond
((eq? kt next-label)
@ -417,6 +432,7 @@
(emit-j asm (if invert? kt kf))))))
(match exp
(($ $values (sym)) (unary emit-br-if-true sym))
(($ $primcall 'heap-object? (a)) (unary* emit-heap-object? a))
(($ $primcall 'null? (a)) (unary emit-br-if-null a))
(($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))