From e2fafeb9012cbe5e3ec63326692a4cc3a22c318e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 19 Jan 2015 16:57:42 +0100 Subject: [PATCH] Keywords have a tc7 * libguile/tags.h (scm_tc7_keyword): Allocate a tc7, so that the VM can have cheap keyword? tests. * libguile/keywords.c: * libguile/keywords.h: Adapt. * libguile/goops.c (scm_class_of, scm_sys_goops_early_init): Capture . * libguile/print.c (iprin1): Inline keyword printer. * libguile/evalext.c (scm_self_evaluating_p): Add keywords here. * libguile/deprecated.h: * libguile/deprecated.c (scm_tc16_keyword): Deprecate. * module/language/cps/compile-bytecode.scm (compile-fun): Add keyword? case, and bitvector? case while we're at it. * module/language/cps/effects-analysis.scm (define-primitive-effects): Add bytevector?, keyword?, and bitvector? cases. * module/language/cps/primitives.scm (*branching-primcall-arities*): Add keyword?. * module/language/cps/types.scm (bitvector?, keyword?, bytevector?): Add branch inferrers. * module/language/tree-il/primitives.scm (*interesting-primitive-names*): (*effect-free-primitives*): (*effect+exception-free-primitives*): Add bytevector?, keyword?, and bitvector?. * module/oop/goops.scm (): New class. * module/system/base/types.scm (%tc7-keyword, cell->object): Add cases. * module/system/vm/assembler.scm (br-if-keyword): New definition. * module/system/vm/disassembler.scm (code-annotation): Add br-if-tc7 case for keywords. * test-suite/tests/types.test ("clonable objects"): Update now that keywords are cloneable. --- libguile/evalext.c | 3 +- libguile/goops.c | 6 ++-- libguile/keywords.c | 33 ++++++-------------- libguile/keywords.h | 6 +--- libguile/print.c | 6 +++- libguile/tags.h | 4 +-- module/language/cps/compile-bytecode.scm | 2 ++ module/language/cps/effects-analysis.scm | 5 ++- module/language/cps/primitives.scm | 3 +- module/language/cps/specialize-primcalls.scm | 10 ++---- module/language/cps/types.scm | 5 ++- module/language/tree-il/compile-cps.scm | 18 ++++++++++- module/language/tree-il/primitives.scm | 5 ++- module/oop/goops.scm | 6 ++-- module/system/base/types.scm | 5 ++- module/system/vm/assembler.scm | 1 + module/system/vm/disassembler.scm | 3 +- test-suite/tests/types.test | 5 ++- 18 files changed, 70 insertions(+), 56 deletions(-) diff --git a/libguile/evalext.c b/libguile/evalext.c index 48a9eff3c..48d9a1718 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2015 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 License @@ -81,6 +81,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_fluid: case scm_tc7_dynamic_state: case scm_tc7_frame: + case scm_tc7_keyword: case scm_tc7_vm_cont: case scm_tc7_number: case scm_tc7_string: diff --git a/libguile/goops.c b/libguile/goops.c index 450ae0d55..ab4d7d7be 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014 +/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -264,6 +264,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return class_dynamic_state; case scm_tc7_frame: return class_frame; + case scm_tc7_keyword: + return scm_class_keyword; case scm_tc7_vm_cont: return class_vm_cont; case scm_tc7_bytevector: @@ -2659,8 +2661,6 @@ create_smob_classes (void) for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i) scm_smob_class[i] = SCM_BOOL_F; - scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword; - for (i = 0; i < scm_numsmob; ++i) if (scm_is_false (scm_smob_class[i])) scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i), diff --git a/libguile/keywords.c b/libguile/keywords.c index f630259d9..49cccd5a5 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, - * 2006, 2008, 2009, 2011, 2013 Free Software Foundation, Inc. + * 2006, 2008, 2009, 2011, 2013, 2015 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 License @@ -41,18 +41,8 @@ static SCM keyword_obarray; -scm_t_bits scm_tc16_keyword; - -#define KEYWORDP(X) (SCM_SMOB_PREDICATE (scm_tc16_keyword, (X))) -#define KEYWORDSYM(X) (SCM_SMOB_OBJECT (X)) - -static int -keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) -{ - scm_puts_unlocked ("#:", port); - scm_display (KEYWORDSYM (exp), port); - return 1; -} +#define SCM_KEYWORDP(x) (SCM_HAS_TYP7 (x, scm_tc7_keyword)) +#define SCM_KEYWORD_SYMBOL(x) (SCM_CELL_OBJECT_1 (x)) SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0, (SCM obj), @@ -60,7 +50,7 @@ SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_keyword_p { - return scm_from_bool (KEYWORDP (obj)); + return scm_from_bool (SCM_KEYWORDP (obj)); } #undef FUNC_NAME @@ -74,11 +64,12 @@ SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0, 0, SCM_ASSERT_TYPE (scm_is_symbol (symbol), symbol, 0, NULL, "symbol"); SCM_CRITICAL_SECTION_START; - /* njrev: NEWSMOB and hashq_set_x can raise errors */ + /* Note: `scm_cell' and `scm_hashq_set_x' can raise an out-of-memory + error. */ keyword = scm_hashq_ref (keyword_obarray, symbol, SCM_BOOL_F); if (scm_is_false (keyword)) { - SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol)); + keyword = scm_cell (scm_tc7_keyword, SCM_UNPACK (symbol)); scm_hashq_set_x (keyword_obarray, symbol, keyword); } SCM_CRITICAL_SECTION_END; @@ -91,15 +82,15 @@ SCM_DEFINE (scm_keyword_to_symbol, "keyword->symbol", 1, 0, 0, "Return the symbol with the same name as @var{keyword}.") #define FUNC_NAME s_scm_keyword_to_symbol { - scm_assert_smob_type (scm_tc16_keyword, keyword); - return KEYWORDSYM (keyword); + SCM_VALIDATE_KEYWORD (1, keyword); + return SCM_KEYWORD_SYMBOL (keyword); } #undef FUNC_NAME int scm_is_keyword (SCM val) { - return KEYWORDP (val); + return SCM_KEYWORDP (val); } SCM @@ -195,13 +186,9 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest, } } -/* njrev: critical sections reviewed so far up to here */ void scm_init_keywords () { - scm_tc16_keyword = scm_make_smob_type ("keyword", 0); - scm_set_smob_print (scm_tc16_keyword, keyword_print); - keyword_obarray = scm_c_make_hash_table (0); #include "libguile/keywords.x" } diff --git a/libguile/keywords.h b/libguile/keywords.h index 3cdb0ecdd..32311dd49 100644 --- a/libguile/keywords.h +++ b/libguile/keywords.h @@ -3,7 +3,7 @@ #ifndef SCM_KEYWORDS_H #define SCM_KEYWORDS_H -/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008, 2015 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 License @@ -27,10 +27,6 @@ -SCM_API scm_t_bits scm_tc16_keyword; - - - SCM_API SCM scm_keyword_p (SCM obj); SCM_API SCM scm_symbol_to_keyword (SCM symbol); SCM_API SCM scm_keyword_to_symbol (SCM keyword); diff --git a/libguile/print.c b/libguile/print.c index 684b3d410..0a2067f1e 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008, - * 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 2013, 2014, 2015 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 License @@ -776,6 +776,10 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_frame: scm_i_frame_print (exp, port, pstate); break; + case scm_tc7_keyword: + scm_puts_unlocked ("#:", port); + scm_iprin1 (scm_keyword_to_symbol (exp), port, pstate); + break; case scm_tc7_vm_cont: scm_i_vm_cont_print (exp, port, pstate); break; diff --git a/libguile/tags.h b/libguile/tags.h index 53d40d89b..a5082f849 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -3,7 +3,7 @@ #ifndef SCM_TAGS_H #define SCM_TAGS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -416,7 +416,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_dynamic_state 45 #define scm_tc7_frame 47 -#define scm_tc7_unused_53 53 +#define scm_tc7_keyword 53 #define scm_tc7_unused_55 55 #define scm_tc7_vm_cont 71 diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index e6dfaad6e..9537e9ce8 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -434,6 +434,8 @@ (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) (($ $primcall 'string? (a)) (unary emit-br-if-string a)) (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) + (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) + (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) ;; Add more TC7 tests here. Keep in sync with ;; *branching-primcall-arities* in (language cps primitives) and ;; the set of macro-instructions in assembly.scm. diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 246b22eb6..8951b407a 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -1,6 +1,6 @@ ;;; Effects analysis on CPS -;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014, 2015 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 @@ -273,6 +273,9 @@ is or might be a read or a write to the same location as A." ((string? arg)) ((number? arg)) ((char? arg)) + ((bytevector? arg)) + ((keyword? arg)) + ((bitvector? arg)) ((procedure? arg)) ((thunk? arg))) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index a095fce33..5f7f474f8 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 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015 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 @@ -75,6 +75,7 @@ (string? . (1 . 1)) (vector? . (1 . 1)) (symbol? . (1 . 1)) + (keyword? . (1 . 1)) (variable? . (1 . 1)) (bitvector? . (1 . 1)) (bytevector? . (1 . 1)) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index e03eb6222..0502fe6c3 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -95,14 +95,8 @@ (('struct-ref s (? immediate-u8? n)) (adapt-val ($primcall 'struct-ref/immediate (s n)))) (('struct-set! s (? immediate-u8? n) x) - ;; Unhappily, and undocumentedly, struct-set! returns the value - ;; that was set. There is code that relies on this. Hackety - ;; hack... - (let-fresh (k*) () - (build-cps-term - ($letk ((k* ($kargs () () - ($continue k src ($primcall 'values (x)))))) - ($continue k* src ($primcall 'struct-set!/immediate (s n x))))))) + (build-cps-term + ($continue k src ($primcall 'struct-set!/immediate (s n x))))) (_ (build-cps-term ($continue k src ($primcall name args)))))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index ca90f50b8..934fa11ce 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1,5 +1,5 @@ ;;; Type analysis on CPS -;;; Copyright (C) 2014 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015 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 License as @@ -480,6 +480,9 @@ minimum, and maximum." (define-simple-predicate-inferrer vector? &vector) (define-simple-predicate-inferrer struct? &struct) (define-simple-predicate-inferrer string? &string) +(define-simple-predicate-inferrer bytevector? &bytevector) +(define-simple-predicate-inferrer bitvector? &bitvector) +(define-simple-predicate-inferrer keyword? &keyword) (define-simple-predicate-inferrer number? &number) (define-simple-predicate-inferrer char? &char) (define-simple-predicate-inferrer procedure? &procedure) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 382231684..a5afa7a7c 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 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2014, 2015 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 @@ -682,6 +682,22 @@ integer." (make-lexical-ref src 'v v) (reverse args) (reverse (iota len)))))) + (($ src 'struct-set! (struct index value)) + ;; Unhappily, and undocumentedly, struct-set! returns the value + ;; that was set. There is code that relies on this. Hackety + ;; hack... + (let ((v (gensym "v "))) + (make-let src + (list 'v) + (list v) + (list value) + (make-seq src + (make-primcall src 'struct-set! + (list struct + index + (make-lexical-ref src 'v v))) + (make-lexical-ref src 'v v))))) + (($ src escape-only? tag body ($ hsrc hmeta ($ _ hreq #f hrest #f () hsyms hbody #f))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index e4e61044a..7bed7832c 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -1,6 +1,6 @@ ;;; open-coding primitive procedures -;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 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 @@ -51,6 +51,7 @@ sqrt abs not pair? null? list? symbol? vector? string? struct? number? char? nil? + bytevector? keyword? bitvector? procedure? thunk? @@ -170,6 +171,7 @@ not pair? null? nil? list? symbol? variable? vector? struct? string? number? char? + bytevector? keyword? bitvector? complex? real? rational? inf? nan? integer? exact? inexact? even? odd? char=? char>? integer->char char->integer number->string string->number @@ -191,6 +193,7 @@ not pair? null? nil? list? symbol? variable? vector? struct? string? number? char? + bytevector? keyword? bitvector? procedure? thunk? acons cons cons* list vector)) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 0376d9eb0..6afd04959 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014, 2015 Free Software Foundation, Inc. ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -58,6 +58,7 @@ + ;; Numbers. @@ -71,7 +72,7 @@ ;; smob-type-name->class procedure. - + ;; Modules. @@ -1740,7 +1741,6 @@ (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) -(define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 6c1d40d7f..c051b3171 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -1,5 +1,5 @@ ;;; 'SCM' type tag decoding. -;;; Copyright (C) 2014 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015 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 License as published by @@ -251,6 +251,7 @@ the matching bits, possibly with bitwise operations to extract it from BITS." (define %tc7-stringbuf 39) (define %tc7-dynamic-state 45) (define %tc7-frame 47) +(define %tc7-keyword 53) (define %tc7-program 69) (define %tc7-vm-continuation 71) (define %tc7-bytevector 77) @@ -472,6 +473,8 @@ using BACKEND." (inferior-object 'hash-table address)) (((_ & #x7f = %tc7-pointer) address) (make-pointer address)) + (((_ & #x7f = %tc7-keyword) symbol) + (symbol->keyword (cell->object symbol backend))) (((_ & #x7f = %tc7-vm-continuation)) (inferior-object 'vm-continuation address)) (((_ & #x7f = %tc7-weak-set)) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 8b9a70ea4..19f812014 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1002,6 +1002,7 @@ returned instead." ;(define-tc7-macro-assembler br-if-fluid 37) ;(define-tc7-macro-assembler br-if-dynamic-state 45) ;(define-tc7-macro-assembler br-if-frame 47) +(define-tc7-macro-assembler br-if-keyword 53) ;(define-tc7-macro-assembler br-if-vm 55) ;(define-tc7-macro-assembler br-if-vm-cont 71) ;(define-tc7-macro-assembler br-if-rtl-program 69) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index adacf1b4b..08aa057a2 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -1,6 +1,6 @@ ;;; Guile bytecode disassembler -;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014 Free Software Foundation, Inc. +;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015 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 @@ -215,6 +215,7 @@ address of that offset." ((7) "variable?") ((13) "vector?") ((15) "string?") + ((53) "keyword?") ((77) "bytevector?") ((95) "bitvector?") (else (number->string tc7))))) diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test index ea71d3ceb..c68262bdc 100644 --- a/test-suite/tests/types.test +++ b/test-suite/tests/types.test @@ -1,6 +1,6 @@ ;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. ;;;; ;;;; This file is part of GNU Guile. ;;;; @@ -48,7 +48,7 @@ 42 (expt 2 28) 3.14 "narrow string" "wide στρινγ" 'symbol 'λ - ;; NB: keywords are SMOBs. + #:keyword #:λ '(2 . 3) (iota 123) '(1 (two ("three"))) #(1 2 3) #(foo bar baz) #vu8(255 254 253) @@ -98,7 +98,6 @@ (with-test-prefix "opaque objects" (test-inferior-objects ((make-guardian) smob (? integer?)) - (#:keyword smob (? integer?)) ((%make-void-port "w") port (? integer?)) ((open-input-string "hello") port (? integer?)) ((lambda () #t) program _) -- 2.20.1