From 1139c10e09a35cecf81b5db37dae188a62c498f4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 26 Oct 2017 21:14:39 +0200 Subject: [PATCH] Heap type predicates preceded by heap-object? * 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. --- module/language/cps/compile-bytecode.scm | 18 ++- module/language/cps/primitives.scm | 134 ++++++++++++++++------- module/language/cps/type-fold.scm | 7 ++ module/language/tree-il/compile-cps.scm | 43 ++++++-- 4 files changed, 150 insertions(+), 52 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 352436e2c..05eb8a60e 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -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)) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index a3e6e38e6..71ce8deed 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -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 @@ -30,6 +30,7 @@ #:use-module (language bytecode) #:export (prim-instruction branching-primitive? + heap-type-predicate? prim-arity )) @@ -69,42 +70,97 @@ (cached-toplevel-box . (1 . 3)) (cached-module-box . (1 . 4)))) -(define *branching-primcall-arities* - '((null? . (1 . 1)) - (nil? . (1 . 1)) - (pair? . (1 . 1)) - (struct? . (1 . 1)) - (string? . (1 . 1)) - (vector? . (1 . 1)) - (symbol? . (1 . 1)) - (keyword? . (1 . 1)) - (variable? . (1 . 1)) - (bitvector? . (1 . 1)) - (bytevector? . (1 . 1)) - (char? . (1 . 1)) - (eq? . (1 . 2)) - (eqv? . (1 . 2)) - (= . (1 . 2)) - (< . (1 . 2)) - (> . (1 . 2)) - (<= . (1 . 2)) - (>= . (1 . 2)) - (u64-= . (1 . 2)) - (u64-< . (1 . 2)) - (u64-> . (1 . 2)) - (u64-<= . (1 . 2)) - (u64->= . (1 . 2)) - (u64-<-scm . (1 . 2)) - (u64-<=-scm . (1 . 2)) - (u64-=-scm . (1 . 2)) - (u64->=-scm . (1 . 2)) - (u64->-scm . (1 . 2)) - (logtest . (1 . 2)) - (f64-= . (1 . 2)) - (f64-< . (1 . 2)) - (f64-> . (1 . 2)) - (f64-<= . (1 . 2)) - (f64->= . (1 . 2)))) +(define *immediate-predicates* + '(fixnum? + char? + eq-nil? + eq-eol? + eq-false? + eq-true? + unspecified? + undefined? + eof-object? + null? ;; '() or #nil + false? ;; #f or #nil + nil? ;; #f or '() or #nil + heap-object?)) + +;; All of the following tests must be dominated by heap-object?. +(define *heap-type-predicates* + '(pair? + struct? + symbol? + variable? + vector? + string? + keyword? + bytevector? + bitvector?)) + +;; FIXME: Support these. +(define *other-predicates* + '(weak-vector? + number? + hash-table? + pointer? + fluid? + stringbuf? + dynamic-state? + frame? + syntax? + program? + vm-continuation? + weak-set? + weak-table? + array? + port? + smob? + bignum? + flonum? + complex? + fraction?)) + +(define (heap-type-predicate? name) + "Is @var{name} a predicate that needs guarding by @code{heap-object?} +before it is lowered to CPS?" + (and (memq name *heap-type-predicates*) #t)) + +(define *comparisons* + '(eq? + eqv? + < + <= + = + u64-< + u64-<= + u64-= + f64-= + f64-< + f64-<= + + ;; FIXME: Expand these. + logtest + u64-<-scm + u64-<=-scm + u64-=-scm + + ;; FIXME: Remove these. + > + >= + u64-> + u64->= + u64->=-scm + u64->-scm + f64-> + f64->=)) + +(define *branching-primcall-arities* (make-hash-table)) +(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 1))) + *immediate-predicates*) +(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 1))) + *heap-type-predicates*) +(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 2))) + *comparisons*) (define (compute-prim-instructions) (let ((table (make-hash-table))) @@ -126,7 +182,7 @@ (hashq-ref (force *prim-instructions*) name)) (define (branching-primitive? name) - (and (assq name *branching-primcall-arities*) #t)) + (and (hashq-ref *branching-primcall-arities* name) #t)) (define *prim-arities* (make-hash-table)) @@ -134,7 +190,7 @@ (or (hashq-ref *prim-arities* name) (let ((arity (cond ((prim-instruction name) => instruction-arity) - ((assq name *branching-primcall-arities*) => cdr) + ((hashq-ref *branching-primcall-arities* name)) (else (error "Primitive of unknown arity" name))))) (hashq-set! *prim-arities* name arity) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index af20a3dfc..b811ad322 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -90,6 +90,13 @@ ((eqv? type type*) (values #t #t)) (else (values #f #f)))))) +(define-unary-branch-folder (heap-object? type min max) + (define &immediate-types (logior &fixnum &char &special-immediate)) + (cond + ((zero? (logand type &immediate-types)) (values #t #t)) + ((type<=? type &immediate-types) (values #t #f)) + (else (values #f #f)))) + ;; All the cases that are in compile-bytecode. (define-unary-type-predicate-folder pair? &pair) (define-unary-type-predicate-folder symbol? &symbol) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 3e1c1d44c..5f5cad8d1 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -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 @@ -522,14 +522,25 @@ (build-term ($continue kf* src ($branch kt ($primcall 'eqv? args)))))))) ((branching-primitive? name) - (convert-args cps args - (lambda (cps args) - (with-cps cps - (let$ k (adapt-arity k src 1)) - (letk kt ($kargs () () ($continue k src ($const #t)))) - (letk kf ($kargs () () ($continue k src ($const #f)))) - (build-term ($continue kf src - ($branch kt ($primcall name args)))))))) + (let () + (define (reify-primcall cps kt kf args) + (if (heap-type-predicate? name) + (with-cps cps + (letk kt* ($kargs () () + ($continue kf src + ($branch kt ($primcall name args))))) + (build-term ($continue kf src + ($branch kt* ($primcall 'heap-object? args))))) + (with-cps cps + (build-term ($continue kf src + ($branch kt ($primcall name args))))))) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (let$ k (adapt-arity k src 1)) + (letk kt ($kargs () () ($continue k src ($const #t)))) + (letk kf ($kargs () () ($continue k src ($const #f)))) + ($ (reify-primcall kt kf args))))))) ((and (eq? name 'not) (match args ((_) #t) (_ #f))) (convert-args cps args (lambda (cps args) @@ -788,9 +799,17 @@ (($ src (? branching-primitive? name) args) (convert-args cps args (lambda (cps args) - (with-cps cps - (build-term ($continue kf src - ($branch kt ($primcall name args)))))))) + (if (heap-type-predicate? name) + (with-cps cps + (letk kt* ($kargs () () + ($continue kf src + ($branch kt ($primcall name args))))) + (build-term + ($continue kf src + ($branch kt* ($primcall 'heap-object? args))))) + (with-cps cps + (build-term ($continue kf src + ($branch kt ($primcall name args))))))))) (($ src test consequent alternate) (with-cps cps (let$ t (convert-test consequent kt kf))