From: Chris Hanson Date: Sun, 14 Jan 2018 03:32:53 +0000 (-0800) Subject: Implement weak-pair procedures as primitives and open-code them. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~366 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c0d3f51ad795a48941606df82ab2b5cb24a5512c;p=mit-scheme.git Implement weak-pair procedures as primitives and open-code them. Also put the primitives in "boot" so they are available early. --- diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm index 087e4b1e4..62d005ac2 100644 --- a/src/compiler/base/utils.scm +++ b/src/compiler/base/utils.scm @@ -318,6 +318,7 @@ USA. (ucode-primitive positive?) (ucode-primitive string?) (ucode-primitive vector?) + (ucode-primitive weak-pair? 1) (ucode-primitive zero-fixnum?) (ucode-primitive zero?))) @@ -333,7 +334,8 @@ USA. (ucode-primitive string-allocate) (ucode-primitive system-pair-cons) (ucode-primitive vector) - (ucode-primitive vector-cons))) + (ucode-primitive vector-cons) + (ucode-primitive weak-cons 2))) (define additional-function-primitives (list (ucode-primitive %record-length) @@ -414,7 +416,9 @@ USA. (ucode-primitive system-vector-size) (ucode-primitive vector-8b-ref) (ucode-primitive vector-length) - (ucode-primitive vector-ref))) + (ucode-primitive vector-ref) + (ucode-primitive weak-car 1) + (ucode-primitive weak-cdr 1))) ;;;; "Foldable" and side-effect-free operators diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm index e31d69a88..8da250000 100644 --- a/src/compiler/rtlgen/opncod.scm +++ b/src/compiler/rtlgen/opncod.scm @@ -691,7 +691,8 @@ USA. (simple-type-test 'flonum? (ucode-type flonum)) (simple-type-test 'pair? (ucode-type pair)) (simple-type-test 'string? (ucode-type string)) - (simple-type-test 'vector? (ucode-type vector)))) + (simple-type-test 'vector? (ucode-type vector)) + (simple-type-test 'weak-pair? (ucode-type weak-cons)))) (define-open-coder/predicate 'EQ? (simple-open-coder @@ -912,6 +913,11 @@ USA. (define-open-coder/value 'CONS (simple-open-coder (open-code/pair-cons (ucode-type pair)) '(0 1) false)) + (define-open-coder/value 'weak-cons + (simple-open-coder (open-code/pair-cons (ucode-type weak-cons)) + '(0 1) + false)) + (define-open-coder/value 'SYSTEM-PAIR-CONS (filter/type-code open-code/pair-cons 0 '(1 2) false)) @@ -1039,6 +1045,8 @@ USA. 0) (user-ref 'CAR rtl:make-fetch (ucode-type pair) 0) (user-ref 'CDR rtl:make-fetch (ucode-type pair) 1) + (user-ref 'weak-car rtl:make-fetch (ucode-type weak-cons) 0) + (user-ref 'weak-cdr rtl:make-fetch (ucode-type weak-cons) 1) (user-ref '%tagged-object-tag rtl:make-fetch (ucode-type tagged-object) 0) (user-ref '%tagged-object-datum rtl:make-fetch (ucode-type tagged-object) 1)) @@ -1095,7 +1103,9 @@ USA. '(0 1) internal-close-coding-for-type-checks))))) (fixed-assignment 'SET-CAR! (ucode-type pair) 0) - (fixed-assignment 'SET-CDR! (ucode-type pair) 1)) + (fixed-assignment 'SET-CDR! (ucode-type pair) 1) + (fixed-assignment 'weak-set-car! (ucode-type weak-cons) 0) + (fixed-assignment 'weak-set-cdr! (ucode-type weak-cons) 1)) (let ((make-assignment (lambda (name type) diff --git a/src/microcode/list.c b/src/microcode/list.c index f207425b6..99424b1b4 100644 --- a/src/microcode/list.c +++ b/src/microcode/list.c @@ -240,13 +240,13 @@ DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CDR!", Prim_sys_set_cdr, 2, 2, 0) PRIMITIVE_RETURN (UNSPECIFIC); } -DEFINE_PRIMITIVE ("%TAGGED-OBJECT?", Prim_tagged_object_p, 1, 1, 0) +DEFINE_PRIMITIVE ("%tagged-object?", Prim_tagged_object_p, 1, 1, 0) { PRIMITIVE_HEADER (1); PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (TAGGED_OBJECT_P (ARG_REF (1)))); } -DEFINE_PRIMITIVE ("%MAKE-TAGGED-OBJECT", Prim_make_tagged_object, 2, 2, 0) +DEFINE_PRIMITIVE ("%make-tagged-object", Prim_make_tagged_object, 2, 2, 0) { PRIMITIVE_HEADER (2); Primitive_GC_If_Needed (2); @@ -256,16 +256,62 @@ DEFINE_PRIMITIVE ("%MAKE-TAGGED-OBJECT", Prim_make_tagged_object, 2, 2, 0) PRIMITIVE_RETURN (result); } -DEFINE_PRIMITIVE ("%TAGGED-OBJECT-TAG", Prim_tagged_object_tag, 1, 1, 0) +DEFINE_PRIMITIVE ("%tagged-object-tag", Prim_tagged_object_tag, 1, 1, 0) { PRIMITIVE_HEADER (1); CHECK_ARG (1, TAGGED_OBJECT_P); PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), 0)); } -DEFINE_PRIMITIVE ("%TAGGED-OBJECT-DATUM", Prim_tagged_object_datum, 1, 1, 0) +DEFINE_PRIMITIVE ("%tagged-object-datum", Prim_tagged_object_datum, 1, 1, 0) { PRIMITIVE_HEADER (1); CHECK_ARG (1, TAGGED_OBJECT_P); PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), 1)); } + +DEFINE_PRIMITIVE ("weak-pair?", Prim_weak_pair_p, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (WEAK_PAIR_P (ARG_REF (1)))); +} + +DEFINE_PRIMITIVE ("weak-cons", Prim_weak_cons, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + Primitive_GC_If_Needed (2); + SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_WEAK_CONS, Free)); + (*Free++) = (ARG_REF (1)); + (*Free++) = (ARG_REF (2)); + PRIMITIVE_RETURN (result); +} + +DEFINE_PRIMITIVE ("weak-car", Prim_weak_car, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + CHECK_ARG (1, WEAK_PAIR_P); + PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), 0)); +} + +DEFINE_PRIMITIVE ("weak-cdr", Prim_weak_cdr, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + CHECK_ARG (1, WEAK_PAIR_P); + PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), 1)); +} + +DEFINE_PRIMITIVE ("weak-set-car!", Prim_weak_set_car, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + CHECK_ARG (1, WEAK_PAIR_P); + MEMORY_SET ((ARG_REF (1)), 0, (ARG_REF (2))); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("weak-set-cdr!", Prim_weak_set_cdr, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + CHECK_ARG (1, WEAK_PAIR_P); + MEMORY_SET ((ARG_REF (1)), 1, (ARG_REF (2))); + PRIMITIVE_RETURN (UNSPECIFIC); +} diff --git a/src/microcode/object.h b/src/microcode/object.h index 197d3da62..063830c4d 100644 --- a/src/microcode/object.h +++ b/src/microcode/object.h @@ -499,6 +499,7 @@ extern bool string_p (SCHEME_OBJECT); 7 #!default 8 #!aux 9 '() + 10 weak #f */ #define SHARP_F MAKE_OBJECT (TC_FALSE, 0) diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index 227379306..783d9e3ba 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -40,7 +40,14 @@ USA. (%record? 1) (%tagged-object-datum 1) (%tagged-object-tag 1) - (%tagged-object? 1)) + (%tagged-object? 1) + (%weak-cons weak-cons 2) + (%weak-car weak-car 1) + (%weak-set-car! weak-set-car! 2) + (weak-cdr 1) + (weak-pair? 1) + (weak-pair/car? weak-car 1) + (weak-set-cdr! 2)) (define (%make-record tag length #!optional fill) (let ((fill (if (default-object? fill) #f fill))) @@ -68,6 +75,34 @@ USA. (%record-set! record 0 tag) record))))))) (expand-cases 16)))) + +(define (weak-cons car cdr) + (%weak-cons (%false->weak-false car) cdr)) + +(define (weak-car weak-pair) + (%weak-false->false (%weak-car weak-pair))) + +(define (weak-set-car! weak-pair object) + (%weak-set-car! weak-pair (%false->weak-false object))) + +(define-integrable (%false->weak-false object) + (if object object %weak-false)) + +(declare (integrate-operator %weak-false->false)) +(define (%weak-false->false object) + (if (%weak-false? object) #f object)) + +(define-integrable (%weak-false? object) + (eq? object %weak-false)) + +(define-integrable %weak-false + (let-syntax + ((ugh + (sc-macro-transformer + (lambda (form use-env) + (declare (ignore form use-env)) + (object-new-type (ucode-type constant) 10))))) + (ugh))) ;;;; Interrupt control diff --git a/src/runtime/list.scm b/src/runtime/list.scm index d9c4a8ea3..7d7f02df7 100644 --- a/src/runtime/list.scm +++ b/src/runtime/list.scm @@ -377,43 +377,19 @@ USA. (define (car+cdr pair) (values (car pair) (cdr pair))) -;;;; Weak Pairs - -(define-integrable (weak-cons car cdr) - (system-pair-cons (ucode-type weak-cons) (or car weak-pair/false) cdr)) - -(define-integrable (weak-pair? object) - (object-type? (ucode-type weak-cons) object)) - -(define-integrable (weak-pair/car? weak-pair) - (system-pair-car weak-pair)) - -(define (weak-car weak-pair) - (let ((car (system-pair-car weak-pair))) - (and (not (eq? car weak-pair/false)) - car))) - -(define-integrable (weak-set-car! weak-pair object) - (system-pair-set-car! weak-pair (or object weak-pair/false))) - -(define-integrable (weak-cdr weak-pair) - (system-pair-cdr weak-pair)) - -(define-integrable (weak-set-cdr! weak-pair object) - (system-pair-set-cdr! weak-pair object)) +;;;; Weak lists (define (weak-list->list items) (let loop ((items* items) (result '())) (if (weak-pair? items*) - (loop (system-pair-cdr items*) - (let ((item (system-pair-car items*))) - (if (not item) - result - (cons (if (eq? item weak-pair/false) #f item) - result)))) + (loop (weak-cdr items*) + (let ((item (%weak-car items*))) + (if item + (cons (%weak-false->false item) result) + result))) (begin (if (not (null? items*)) - (error:not-a weak-list? items 'WEAK-LIST->LIST)) + (error:not-a weak-list? items 'weak-list->list)) (reverse! result))))) (define (list->weak-list items) @@ -423,12 +399,9 @@ USA. (weak-cons (car items*) result)) (begin (if (not (null? items*)) - (error:not-a list? items 'LIST->WEAK-LIST)) + (error:not-a list? items 'list->weak-list)) result)))) -(define weak-pair/false - "weak-pair/false") - (define (weak-list? object) (let loop ((l1 object) (l2 object)) (if (weak-pair? l1) @@ -438,45 +411,44 @@ USA. (loop (weak-cdr l1) (weak-cdr l2)) (null? l1)))) (null? l1)))) - -(define (weak-memq object items) - (let ((object (or object weak-pair/false))) + +(define (weak-memq item items) + (let ((item (%false->weak-false item))) (let loop ((items* items)) (if (weak-pair? items*) - (if (eq? object (system-pair-car items*)) + (if (eq? item (%weak-car items*)) items* - (loop (system-pair-cdr items*))) + (loop (weak-cdr items*))) (begin (if (not (null? items*)) - (error:not-a weak-list? items 'WEAK-MEMQ)) + (error:not-a weak-list? items 'weak-memq)) #f))))) (define (weak-delq! item items) - (letrec ((trim-initial-segment - (lambda (items*) - (if (weak-pair? items*) - (if (or (eq? item (system-pair-car items*)) - (eq? #f (system-pair-car items*))) - (trim-initial-segment (system-pair-cdr items*)) - (begin - (locate-initial-segment items* - (system-pair-cdr items*)) - items*)) - (begin - (if (not (null? items*)) - (error:not-a weak-list? items 'WEAK-DELQ!)) - '())))) - (locate-initial-segment - (lambda (last this) - (if (weak-pair? this) - (if (or (eq? item (system-pair-car this)) - (eq? #f (system-pair-car this))) - (set-cdr! last - (trim-initial-segment (system-pair-cdr this))) - (locate-initial-segment this (system-pair-cdr this))) - (if (not (null? this)) - (error:not-a weak-list? items 'WEAK-DELQ!)))))) - (trim-initial-segment items))) + (let ((item (%false->weak-false item))) + (letrec ((trim-initial-segment + (lambda (items*) + (if (weak-pair? items*) + (if (or (eq? item (%weak-car items*)) + (eq? #f (%weak-car items*))) + (trim-initial-segment (weak-cdr items*)) + (begin + (locate-initial-segment items* (weak-cdr items*)) + items*)) + (begin + (if (not (null? items*)) + (error:not-a weak-list? items 'weak-delq!)) + '())))) + (locate-initial-segment + (lambda (last this) + (if (weak-pair? this) + (if (or (eq? item (%weak-car this)) + (eq? #f (%weak-car this))) + (set-cdr! last (trim-initial-segment (weak-cdr this))) + (locate-initial-segment this (weak-cdr this))) + (if (not (null? this)) + (error:not-a weak-list? items 'weak-delq!)))))) + (trim-initial-segment items)))) ;;;; General CAR CDR diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 767d115a8..181d77039 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -135,6 +135,7 @@ USA. (files "boot") (parent (runtime)) (export () + %false->weak-false %make-record %make-tagged-object %record @@ -145,6 +146,11 @@ USA. %tagged-object-datum %tagged-object-tag %tagged-object? + %weak-car + %weak-cons + %weak-false->false + %weak-false? + %weak-set-car! bracketed-unparser-method bytes-per-object default-object @@ -174,6 +180,13 @@ USA. simple-unparser-method standard-unparser-method unparser-method? + weak-car + weak-cdr + weak-cons + weak-pair/car? + weak-pair? + weak-set-car! + weak-set-cdr! with-absolutely-no-interrupts with-limited-interrupts without-interrupts) @@ -3020,17 +3033,10 @@ USA. third tree-copy unique-keyword-list? - weak-car - weak-cdr - weak-cons weak-delq! weak-list->list weak-list? weak-memq - weak-pair/car? - weak-pair? - weak-set-car! - weak-set-cdr! xcons)) (define-package (runtime lambda-list) diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm index e1cd2ed3d..7d43deb24 100644 --- a/src/sf/gconst.scm +++ b/src/sf/gconst.scm @@ -41,15 +41,18 @@ USA. UNSPECIFIC)) (define global-primitives - '((%MAKE-TAGGED-OBJECT %MAKE-TAGGED-OBJECT 2) + '((%make-tagged-object %make-tagged-object 2) (%RECORD %RECORD) (%RECORD-LENGTH %RECORD-LENGTH) (%RECORD-REF %RECORD-REF) (%RECORD-SET! %RECORD-SET!) (%RECORD? %RECORD?) - (%TAGGED-OBJECT-DATUM %TAGGED-OBJECT-DATUM 1) - (%TAGGED-OBJECT-TAG %TAGGED-OBJECT-TAG 1) - (%TAGGED-OBJECT? %TAGGED-OBJECT? 1) + (%tagged-object-datum %tagged-object-datum 1) + (%tagged-object-tag %tagged-object-tag 1) + (%tagged-object? %tagged-object? 1) + (%weak-cons weak-cons 2) + (%weak-car weak-car 1) + (%weak-set-car! weak-set-car! 2) (BIT-STRING->UNSIGNED-INTEGER BIT-STRING->UNSIGNED-INTEGER) (BIT-STRING-ALLOCATE BIT-STRING-ALLOCATE) (BIT-STRING-AND! BIT-STRING-AND!) @@ -215,6 +218,10 @@ USA. (VECTOR-REF VECTOR-REF) (VECTOR-SET! VECTOR-SET!) (VECTOR? VECTOR?) + (weak-cdr weak-cdr 1) + (weak-pair? weak-pair? 1) + (weak-pair/car? weak-car 1) + (weak-set-cdr! weak-set-cdr! 2) (WITH-HISTORY-DISABLED WITH-HISTORY-DISABLED) (WITH-INTERRUPT-MASK WITH-INTERRUPT-MASK) (WRITE-BITS! WRITE-BITS!))) \ No newline at end of file