From 20560a34d270bb77f0bf6a9a8405042b01c8f71d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 8 Jan 1993 00:05:44 +0000 Subject: [PATCH] Fixed bug in inline expander for OBJECT-TYPE?. Added inline expanders for primitives: GET-INTERRUPT-ENABLES, SET-INTERRUPT-ENABLES!, PRIMITIVE-GET-FREE, PRIMITIVE-INCREMENT-FREE, HEAP-AVAILABLE?, and SET-STRING-LENGTH!. Some of these primitives are new with microcode version 11.125. For the MIPS, added support for open-coding of FIXNUM-LSH. --- v7/src/compiler/base/make.scm | 6 +- v7/src/compiler/machines/alpha/machin.scm | 13 +- v7/src/compiler/machines/bobcat/dassm2.scm | 7 +- v7/src/compiler/machines/bobcat/machin.scm | 8 +- v7/src/compiler/machines/i386/machin.scm | 11 +- v7/src/compiler/machines/mips/machin.scm | 15 +- v7/src/compiler/machines/mips/rulfix.scm | 333 ++++++++++--------- v7/src/compiler/machines/mips/rulrew.scm | 13 +- v7/src/compiler/machines/spectrum/machin.scm | 11 +- v7/src/compiler/machines/vax/dassm2.scm | 8 +- v7/src/compiler/machines/vax/machin.scm | 8 +- v7/src/compiler/rtlbase/rtlty2.scm | 13 +- v7/src/compiler/rtlgen/opncod.scm | 289 +++++++++++----- 13 files changed, 459 insertions(+), 276 deletions(-) diff --git a/v7/src/compiler/base/make.scm b/v7/src/compiler/base/make.scm index 54759f834..32ff77570 100644 --- a/v7/src/compiler/base/make.scm +++ b/v7/src/compiler/base/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: make.scm,v 4.96 1992/12/28 22:03:26 cph Exp $ +$Id: make.scm,v 4.97 1993/01/08 00:05:44 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -46,5 +46,5 @@ MIT in each case. |# (initialize-package! '(COMPILER DECLARATIONS))) (add-system! (make-system (string-append "Liar (" architecture-name ")") - 4 96 + 4 97 '()))) \ No newline at end of file diff --git a/v7/src/compiler/machines/alpha/machin.scm b/v7/src/compiler/machines/alpha/machin.scm index daaf10687..c3700331b 100644 --- a/v7/src/compiler/machines/alpha/machin.scm +++ b/v7/src/compiler/machines/alpha/machin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: machin.scm,v 1.3 1992/11/18 03:52:32 gjr Exp $ +$Id: machin.scm,v 1.4 1993/01/08 00:03:32 cph Exp $ -Copyright (c) 1992 Digital Equipment Corporation (D.E.C.) +Copyright (c) 1992-1993 Digital Equipment Corporation (D.E.C.) This software was developed at the Digital Equipment Corporation Cambridge Research Laboratory. Permission to copy this software, to @@ -384,6 +384,10 @@ case. (interpreter-dynamic-link)) ((VALUE) (interpreter-value-register)) + ((FREE) + (interpreter-free-pointer)) + ((MEMORY-TOP) + (rtl:make-machine-register regnum:memtop)) ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) @@ -400,8 +404,7 @@ case. (define (rtl:interpreter-register? rtl-register) (case rtl-register - ((MEMORY-TOP) 0) - ((STACK-GUARD) 1) + ((INT-MASK) 1) ((ENVIRONMENT) 3) ((TEMPORARY) 4) (else false))) @@ -409,7 +412,7 @@ case. (define (rtl:interpreter-register->offset locative) (or (rtl:interpreter-register? locative) (error "Unknown register type" locative))) - + (define (rtl:constant-cost expression) ;; Magic numbers. Cycles needed to generate value in specified ;; register. diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm index fd31a7546..3bc090bc6 100644 --- a/v7/src/compiler/machines/bobcat/dassm2.scm +++ b/v7/src/compiler/machines/bobcat/dassm2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dassm2.scm,v 4.20 1992/09/25 01:17:58 cph Exp $ +$Id: dassm2.scm,v 4.21 1993/01/08 00:03:51 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -291,10 +291,11 @@ MIT in each case. |# (make-entries (+ index 8) (cdr names))))) `(;; Interpreter registers (0 . (REGISTER MEMORY-TOP)) - (4 . (REGISTER STACK-GUARD)) + (4 . (REGISTER INT-MASK)) (8 . (REGISTER VALUE)) (12 . (REGISTER ENVIRONMENT)) (16 . (REGISTER TEMPORARY)) + (44 . (REGISTER STACK-GUARD)) ;; Interpreter entry points ,@(make-entries first-entry diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index 64fd64d1d..838fc8ef0 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: machin.scm,v 4.28 1992/11/18 03:47:54 gjr Exp $ +$Id: machin.scm,v 4.29 1993/01/08 00:04:03 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -328,6 +328,8 @@ MIT in each case. |# (interpreter-dynamic-link)) ((VALUE) (interpreter-value-register)) + ((FREE) + (interpreter-free-pointer)) ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) @@ -345,7 +347,7 @@ MIT in each case. |# (define (rtl:interpreter-register? rtl-register) (case rtl-register ((MEMORY-TOP) 0) - ((STACK-GUARD) 1) + ((INT-MASK) 1) ((ENVIRONMENT) 3) ((TEMPORARY) 4) (else false))) diff --git a/v7/src/compiler/machines/i386/machin.scm b/v7/src/compiler/machines/i386/machin.scm index 17f9bf411..32afe90b3 100644 --- a/v7/src/compiler/machines/i386/machin.scm +++ b/v7/src/compiler/machines/i386/machin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: machin.scm,v 1.15 1992/11/18 03:49:35 gjr Exp $ +$Id: machin.scm,v 1.16 1993/01/08 00:04:22 cph Exp $ -Copyright (c) 1992 Massachusetts Institute of Technology +Copyright (c) 1992-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -171,6 +171,7 @@ MIT in each case. |# (error "illegal machine register" register)))) (define-integrable register-block/memtop-offset 0) +(define-integrable register-block/int-mask-offset 1) (define-integrable register-block/value-offset 2) (define-integrable register-block/environment-offset 3) (define-integrable register-block/dynamic-link-offset 4) ; compiler temp @@ -260,6 +261,8 @@ MIT in each case. |# ((VALUE) (interpreter-value-register)) |# + ((FREE) + (interpreter-free-pointer)) ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) @@ -279,6 +282,8 @@ MIT in each case. |# (case rtl-register ((MEMORY-TOP) register-block/memtop-offset) + ((INT-MASK) + register-block/int-mask-offset) ((STACK-GUARD) register-block/stack-guard-offset) ((VALUE) @@ -293,7 +298,7 @@ MIT in each case. |# (define (rtl:interpreter-register->offset locative) (or (rtl:interpreter-register? locative) (error "Unknown register type" locative))) - + (define (rtl:constant-cost expression) ;; i486 clock count for instruction to construct/fetch into register. (let ((if-integer diff --git a/v7/src/compiler/machines/mips/machin.scm b/v7/src/compiler/machines/mips/machin.scm index b16a9e8cc..144037513 100644 --- a/v7/src/compiler/machines/mips/machin.scm +++ b/v7/src/compiler/machines/mips/machin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: machin.scm,v 1.10 1992/12/22 02:17:06 cph Exp $ +$Id: machin.scm,v 1.11 1993/01/08 00:04:37 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -321,6 +321,10 @@ MIT in each case. |# (interpreter-dynamic-link)) ((VALUE) (interpreter-value-register)) + ((MEMORY-TOP) + (rtl:make-machine-register regnum:memtop)) + ((FREE) + (interpreter-free-pointer)) ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) @@ -337,8 +341,7 @@ MIT in each case. |# (define (rtl:interpreter-register? rtl-register) (case rtl-register - ((MEMORY-TOP) 0) - ((STACK-GUARD) 1) + ((INT-MASK) 1) ((ENVIRONMENT) 3) ((TEMPORARY) 4) (else false))) @@ -346,7 +349,7 @@ MIT in each case. |# (define (rtl:interpreter-register->offset locative) (or (rtl:interpreter-register? locative) (error "Unknown register type" locative))) - + (define (rtl:constant-cost expression) ;; Magic numbers. (let ((if-integer @@ -386,7 +389,7 @@ MIT in each case. |# true) (define compiler:primitives-with-no-open-coding - '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER FIXNUM-LSH + '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER INTEGER-QUOTIENT INTEGER-REMAINDER &/ QUOTIENT REMAINDER FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND diff --git a/v7/src/compiler/machines/mips/rulfix.scm b/v7/src/compiler/machines/mips/rulfix.scm index 5b10374c5..647c093e9 100644 --- a/v7/src/compiler/machines/mips/rulfix.scm +++ b/v7/src/compiler/machines/mips/rulfix.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rulfix.scm,v 1.8 1992/12/28 22:01:22 cph Exp $ +$Id: rulfix.scm,v 1.9 1993/01/08 00:04:44 cph Exp $ -Copyright (c) 1989-1992 Massachusetts Institute of Technology +Copyright (c) 1989-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -177,6 +177,77 @@ MIT in each case. |# (define fixnum-methods/1-arg (list 'FIXNUM-METHODS/1-ARG)) +(define-rule statement + ;; execute a binary fixnum operation + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + (standard-binary-conversion source1 source2 target + (lambda (source1 source2 target) + ((fixnum-2-args/operator operation) target source1 source2 overflow?)))) + +(define (fixnum-2-args/operator operation) + (lookup-arithmetic-method operation fixnum-methods/2-args)) + +(define fixnum-methods/2-args + (list 'FIXNUM-METHODS/2-ARGS)) + +(define-rule statement + ;; execute binary fixnum operation with constant second arg + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source)) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (? overflow?))) + (QUALIFIER (fixnum-2-args/operator/register*constant? operation)) + (standard-unary-conversion source target + (lambda (source target) + ((fixnum-2-args/operator/register*constant operation) + target source constant overflow?)))) + +(define-rule statement + ;; execute binary fixnum operation with constant first arg + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (OBJECT->FIXNUM (CONSTANT (? constant))) + (REGISTER (? source)) + (? overflow?))) + (QUALIFIER + (or (fixnum-2-args/operator/constant*register? operation) + (and (fixnum-2-args/commutative? operation) + (fixnum-2-args/operator/register*constant? operation)))) + (standard-unary-conversion source target + (lambda (source target) + (if (fixnum-2-args/commutative? operation) + ((fixnum-2-args/operator/register*constant operation) + target source constant overflow?) + ((fixnum-2-args/operator/constant*register operation) + target constant source overflow?))))) + +(define (fixnum-2-args/commutative? operator) + (memq operator + '(PLUS-FIXNUM MULTIPLY-FIXNUM FIXNUM-AND FIXNUM-OR FIXNUM-XOR))) + +(define (fixnum-2-args/operator/register*constant operation) + (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant)) + +(define (fixnum-2-args/operator/register*constant? operation) + (arithmetic-method? operation fixnum-methods/2-args/register*constant)) + +(define fixnum-methods/2-args/register*constant + (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT)) + +(define (fixnum-2-args/operator/constant*register operation) + (lookup-arithmetic-method operation fixnum-methods/2-args/constant*register)) + +(define (fixnum-2-args/operator/constant*register? operation) + (arithmetic-method? operation fixnum-methods/2-args/constant*register)) + +(define fixnum-methods/2-args/constant*register + (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER)) + (define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg (lambda (tgt src overflow?) (fixnum-add-constant tgt src 1 overflow?))) @@ -229,35 +300,18 @@ MIT in each case. |# (BLTZ ,tgt (@PCR ,if-no-overflow)) (NOP))))))) (LAP))))) - -(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg - (lambda (tgt src overflow?) - overflow? - (LAP (NOR ,tgt 0 ,src)))) -(define-rule statement - ;; execute a binary fixnum operation - (ASSIGN (REGISTER (? target)) - (FIXNUM-2-ARGS (? operation) - (REGISTER (? source1)) - (REGISTER (? source2)) - (? overflow?))) - (standard-binary-conversion source1 source2 target - (lambda (source1 source2 target) - ((fixnum-2-args/operator operation) target source1 source2 overflow?)))) - -(define (fixnum-2-args/operator operation) - (lookup-arithmetic-method operation fixnum-methods/2-args)) - -(define fixnum-methods/2-args - (list 'FIXNUM-METHODS/2-ARGS)) - (define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args (lambda (tgt src1 src2 overflow?) (if overflow? (do-overflow-addition tgt src1 src2) (LAP (ADDU ,tgt ,src1 ,src2))))) +(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (fixnum-add-constant tgt src constant overflow?))) + ;;; Use of REGNUM:ASSEMBLER-TEMP is OK here, but only because its ;;; value is not used after the branch instruction that tests it. ;;; The long form of the @PCR branch will test it correctly, but @@ -323,6 +377,21 @@ MIT in each case. |# (do-overflow-subtraction tgt src1 src2)) (LAP (SUB ,tgt ,src1 ,src2))))) +(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (fixnum-add-constant tgt src (- constant) overflow?))) + +(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/constant*register + (lambda (tgt constant src overflow?) + (guarantee-signed-fixnum constant) + (with-values (lambda () (immediate->register (* constant fixnum-1))) + (lambda (prefix alias) + (LAP ,@prefix + ,@(if overflow? + (do-overflow-subtraction tgt alias src) + (LAP (SUB ,tgt ,alias ,src)))))))) + (define (do-overflow-subtraction tgt src1 src2) (set-current-branches! (lambda (if-overflow) @@ -348,6 +417,38 @@ MIT in each case. |# (BLTZ ,regnum:assembler-temp (@PCR ,if-no-overflow)))) (NOP)))) (LAP)) + +(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (do-multiply tgt src1 src2 overflow?))) + +(define-arithmetic-method 'MULTIPLY-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (tgt src constant overflow?) + (cond ((zero? constant) + (if overflow? (no-overflow-branches!)) + (LAP (ADDI ,tgt 0 0))) + ((= constant 1) + (if overflow? (no-overflow-branches!)) + (LAP (ADD ,tgt 0 ,src))) + ((let loop ((n constant)) + (and (> n 0) + (if (= n 1) + 0 + (and (even? n) + (let ((m (loop (quotient n 2)))) + (and m + (+ m 1))))))) + => + (lambda (power-of-two) + (if overflow? + (do-left-shift-overflow tgt src power-of-two) + (LAP (SLL ,tgt ,src ,power-of-two))))) + (else + (with-values (lambda () (immediate->register (* constant fixnum-1))) + (lambda (prefix alias) + (LAP ,@prefix + ,@(do-multiply tgt src alias overflow?)))))))) (define (do-multiply tgt src1 src2 overflow?) (if overflow? @@ -369,7 +470,37 @@ MIT in each case. |# (MULT ,regnum:assembler-temp ,src2) (MFLO ,tgt))) -(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args do-multiply) +(define (do-left-shift-overflow tgt src power-of-two) + (if (= tgt src) + (let ((temp (standard-temporary!))) + (set-current-branches! + (lambda (if-overflow) + (LAP (SLL ,temp ,src ,power-of-two) + (SRA ,regnum:assembler-temp ,temp ,power-of-two) + (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow)) + (ADD ,tgt 0 ,temp))) + (lambda (if-no-overflow) + (LAP (SLL ,temp ,src ,power-of-two) + (SRA ,regnum:assembler-temp ,temp ,power-of-two) + (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow)) + (ADD ,tgt 0 ,temp))))) + (set-current-branches! + (lambda (if-overflow) + (LAP (SLL ,tgt ,src ,power-of-two) + (SRA ,regnum:assembler-temp ,tgt ,power-of-two) + (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow)) + (NOP))) + (lambda (if-no-overflow) + (LAP (SLL ,tgt ,src ,power-of-two) + (SRA ,regnum:assembler-temp ,tgt ,power-of-two) + (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow)) + (NOP))))) + (LAP)) + +(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg + (lambda (tgt src overflow?) + overflow? + (LAP (NOR ,tgt 0 ,src)))) (define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args (lambda (tgt src1 src2 overflow?) @@ -391,138 +522,36 @@ MIT in each case. |# (lambda (tgt src1 src2 overflow?) overflow? (LAP (XOR ,tgt ,src1 ,src2)))) - -(define-rule statement - ;; execute binary fixnum operation with constant second arg - (ASSIGN (REGISTER (? target)) - (FIXNUM-2-ARGS (? operation) - (REGISTER (? source)) - (OBJECT->FIXNUM (CONSTANT (? constant))) - (? overflow?))) - (QUALIFIER (fixnum-2-args/operator/register*constant? operation)) - (standard-unary-conversion source target - (lambda (source target) - ((fixnum-2-args/operator/register*constant operation) - target source constant overflow?)))) - -(define-rule statement - ;; execute binary fixnum operation with constant first arg - (ASSIGN (REGISTER (? target)) - (FIXNUM-2-ARGS (? operation) - (OBJECT->FIXNUM (CONSTANT (? constant))) - (REGISTER (? source)) - (? overflow?))) - (QUALIFIER - (or (fixnum-2-args/operator/constant*register? operation) - (and (fixnum-2-args/commutative? operation) - (fixnum-2-args/operator/register*constant? operation)))) - (standard-unary-conversion source target - (lambda (source target) - (if (fixnum-2-args/commutative? operation) - ((fixnum-2-args/operator/register*constant operation) - target source constant overflow?) - ((fixnum-2-args/operator/constant*register operation) - target constant source overflow?))))) - -(define (fixnum-2-args/commutative? operator) - (memq operator - '(PLUS-FIXNUM MULTIPLY-FIXNUM FIXNUM-AND FIXNUM-OR FIXNUM-XOR))) - -(define (fixnum-2-args/operator/register*constant operation) - (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant)) - -(define (fixnum-2-args/operator/register*constant? operation) - (arithmetic-method? operation fixnum-methods/2-args/register*constant)) - -(define fixnum-methods/2-args/register*constant - (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT)) -(define (fixnum-2-args/operator/constant*register operation) - (lookup-arithmetic-method operation fixnum-methods/2-args/constant*register)) - -(define (fixnum-2-args/operator/constant*register? operation) - (arithmetic-method? operation fixnum-methods/2-args/constant*register)) - -(define fixnum-methods/2-args/constant*register - (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER)) - -(define-arithmetic-method 'PLUS-FIXNUM - fixnum-methods/2-args/register*constant - (lambda (tgt src constant overflow?) - (guarantee-signed-fixnum constant) - (fixnum-add-constant tgt src constant overflow?))) - -(define-arithmetic-method 'MINUS-FIXNUM - fixnum-methods/2-args/register*constant +(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + overflow? + (let ((merge (generate-label 'LSH-MERGE)) + (neg (generate-label 'LSH-NEG))) + (LAP (BLTZ ,src2 (@PCR ,neg)) + (SRA ,regnum:assembler-temp ,src2 ,scheme-type-width) + (BGEZ 0 (@PCR ,merge)) + (SLLV ,tgt ,src1 ,regnum:assembler-temp) + (LABEL ,neg) + (SUB ,regnum:assembler-temp 0 ,regnum:assembler-temp) + (SRLV ,tgt ,src1 ,regnum:assembler-temp) + (SRL ,tgt ,tgt ,scheme-type-width) + (SLL ,tgt ,tgt ,scheme-type-width) + (LABEL ,merge))))) + +(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args/register*constant (lambda (tgt src constant overflow?) + overflow? (guarantee-signed-fixnum constant) - (fixnum-add-constant tgt src (- constant) overflow?))) - -(define-arithmetic-method 'MULTIPLY-FIXNUM - fixnum-methods/2-args/register*constant - (lambda (tgt src constant overflow?) - (cond ((zero? constant) - (if overflow? (no-overflow-branches!)) - (LAP (ADDI ,tgt 0 0))) - ((= constant 1) - (if overflow? (no-overflow-branches!)) + (cond ((= constant 0) (LAP (ADD ,tgt 0 ,src))) - ((let loop ((n constant)) - (and (> n 0) - (if (= n 1) - 0 - (and (even? n) - (let ((m (loop (quotient n 2)))) - (and m - (+ m 1))))))) - => - (lambda (power-of-two) - (if overflow? - (do-left-shift-overflow tgt src power-of-two) - (LAP (SLL ,tgt ,src ,power-of-two))))) + ((<= 1 constant (- scheme-datum-width 1)) + (LAP (SLL ,tgt ,src ,constant))) + ((<= 1 (- constant) (- scheme-datum-width 1)) + (LAP (SRL ,tgt ,src ,(+ (- constant) scheme-type-width)) + (SLL ,tgt ,tgt ,scheme-type-width))) (else - (with-values (lambda () (immediate->register (* constant fixnum-1))) - (lambda (prefix alias) - (LAP ,@prefix - ,@(do-multiply tgt src alias overflow?)))))))) - -(define (do-left-shift-overflow tgt src power-of-two) - (if (= tgt src) - (let ((temp (standard-temporary!))) - (set-current-branches! - (lambda (if-overflow) - (LAP (SLL ,temp ,src ,power-of-two) - (SRA ,regnum:assembler-temp ,temp ,power-of-two) - (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow)) - (ADD ,tgt 0 ,temp))) - (lambda (if-no-overflow) - (LAP (SLL ,temp ,src ,power-of-two) - (SRA ,regnum:assembler-temp ,temp ,power-of-two) - (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow)) - (ADD ,tgt 0 ,temp))))) - (set-current-branches! - (lambda (if-overflow) - (LAP (SLL ,tgt ,src ,power-of-two) - (SRA ,regnum:assembler-temp ,tgt ,power-of-two) - (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow)) - (NOP))) - (lambda (if-no-overflow) - (LAP (SLL ,tgt ,src ,power-of-two) - (SRA ,regnum:assembler-temp ,tgt ,power-of-two) - (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow)) - (NOP))))) - (LAP)) - -(define-arithmetic-method 'MINUS-FIXNUM - fixnum-methods/2-args/constant*register - (lambda (tgt constant src overflow?) - (guarantee-signed-fixnum constant) - (with-values (lambda () (immediate->register (* constant fixnum-1))) - (lambda (prefix alias) - (LAP ,@prefix - ,@(if overflow? - (do-overflow-subtraction tgt alias src) - (LAP (SUB ,tgt ,alias ,src)))))))) + (LAP (ADDIU ,tgt 0 0)))))) ;;;; Predicates diff --git a/v7/src/compiler/machines/mips/rulrew.scm b/v7/src/compiler/machines/mips/rulrew.scm index b0e2819bc..8f12e5170 100644 --- a/v7/src/compiler/machines/mips/rulrew.scm +++ b/v7/src/compiler/machines/mips/rulrew.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rulrew.scm,v 1.4 1992/12/23 18:14:20 cph Exp $ +$Id: rulrew.scm,v 1.5 1993/01/08 00:04:50 cph Exp $ -Copyright (c) 1990-92 Massachusetts Institute of Technology +Copyright (c) 1990-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -147,6 +147,15 @@ MIT in each case. |# (QUALIFIER (rtl:constant-fixnum? source)) (rtl:make-object->fixnum source)) +(define-rule rewriting + (FIXNUM-2-ARGS FIXNUM-LSH + (? operand-1) + (REGISTER (? operand-2 register-known-value)) + #F) + (QUALIFIER (and (rtl:register? operand-1) + (rtl:constant-fixnum? operand-2))) + (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F)) + (define-rule rewriting (FIXNUM-2-ARGS MULTIPLY-FIXNUM (REGISTER (? operand-1 register-known-value)) diff --git a/v7/src/compiler/machines/spectrum/machin.scm b/v7/src/compiler/machines/spectrum/machin.scm index 36bc4d879..334d09b0d 100644 --- a/v7/src/compiler/machines/spectrum/machin.scm +++ b/v7/src/compiler/machines/spectrum/machin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: machin.scm,v 4.26 1992/11/18 00:46:45 gjr Exp $ +$Id: machin.scm,v 4.27 1993/01/08 00:05:02 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -326,6 +326,10 @@ MIT in each case. |# (interpreter-dynamic-link)) ((VALUE) (interpreter-value-register)) + ((FREE) + (interpreter-free-pointer)) + ((MEMORY-TOP) + (rtl:make-machine-register regnum:memtop-pointer)) ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) @@ -342,8 +346,7 @@ MIT in each case. |# (define (rtl:interpreter-register? rtl-register) (case rtl-register - ((MEMORY-TOP) 0) - ((STACK-GUARD) 1) + ((INT-MASK) 1) ((ENVIRONMENT) 3) ((TEMPORARY) 4) (else false))) diff --git a/v7/src/compiler/machines/vax/dassm2.scm b/v7/src/compiler/machines/vax/dassm2.scm index a25533037..4361aa0ea 100644 --- a/v7/src/compiler/machines/vax/dassm2.scm +++ b/v7/src/compiler/machines/vax/dassm2.scm @@ -1,9 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/dassm2.scm,v 4.11 1992/08/11 04:43:37 jinx Exp $ -$MC68020-Header: dassm2.scm,v 4.17 90/05/03 15:17:04 GMT jinx Exp $ +$Id: dassm2.scm,v 4.12 1993/01/08 00:05:17 cph Exp $ -Copyright (c) 1987-1992 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -297,7 +296,7 @@ MIT in each case. |# (make-entries (+ index 6) (cdr names))))) `(;; Interpreter registers (0 . (REGISTER MEMORY-TOP)) - (4 . (REGISTER STACK-GUARD)) + (4 . (REGISTER INT-MASK)) (8 . (REGISTER VALUE)) (12 . (REGISTER ENVIRONMENT)) (16 . (REGISTER TEMPORARY)) @@ -306,6 +305,7 @@ MIT in each case. |# (28 . (REGISTER LEXPR-PRIMITIVE-ACTUALS)) (32 . (REGISTER MINIMUM-LENGTH)) (36 . (REGISTER PRIMITIVE)) + (44 . (REGISTER STACK-GUARD)) ;; Interface entry points ,@(make-entries #x0280 diff --git a/v7/src/compiler/machines/vax/machin.scm b/v7/src/compiler/machines/vax/machin.scm index cf3f9625c..5db3e9384 100644 --- a/v7/src/compiler/machines/vax/machin.scm +++ b/v7/src/compiler/machines/vax/machin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: machin.scm,v 4.10 1992/11/18 03:55:03 gjr Exp $ +$Id: machin.scm,v 4.11 1993/01/08 00:05:10 cph Exp $ -Copyright (c) 1987-1992 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -225,6 +225,8 @@ MIT in each case. |# (interpreter-dynamic-link)) ((VALUE) (interpreter-value-register)) + ((FREE) + (interpreter-free-pointer)) ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) @@ -243,7 +245,7 @@ MIT in each case. |# (define (rtl:interpreter-register? rtl-register) (case rtl-register ((MEMORY-TOP) 0) - ((STACK-GUARD) 1) + ((INT-MASK) 1) #| ((VALUE) 2) |# ((ENVIRONMENT) 3) ((TEMPORARY) 4) diff --git a/v7/src/compiler/rtlbase/rtlty2.scm b/v7/src/compiler/rtlbase/rtlty2.scm index 947c1318a..530d0b43a 100644 --- a/v7/src/compiler/rtlbase/rtlty2.scm +++ b/v7/src/compiler/rtlbase/rtlty2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rtlty2.scm,v 4.10 1992/11/18 00:48:50 gjr Exp $ +$Id: rtlty2.scm,v 4.11 1993/01/08 00:05:27 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -68,6 +68,15 @@ MIT in each case. |# (define-integrable register:value 'VALUE) +(define-integrable register:int-mask + 'INT-MASK) + +(define-integrable register:memory-top + 'MEMORY-TOP) + +(define-integrable register:free + 'FREE) + (define-integrable (rtl:interpreter-call-result:access) (rtl:make-fetch 'INTERPRETER-CALL-RESULT:ACCESS)) diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index 9ce0b0587..8ac9992b3 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: opncod.scm,v 4.56 1992/12/30 14:13:45 gjr Exp $ +$Id: opncod.scm,v 4.57 1993/01/08 00:05:35 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -452,7 +452,8 @@ MIT in each case. |# (define (index-locative-generator make-locative header-length-in-objects - address-units-per-index) + address-units-per-index + scfg*scfg->scfg!) (let ((header-length-in-indexes (back-end:* header-length-in-objects (back-end:quotient address-units-per-object @@ -493,19 +494,26 @@ MIT in each case. |# (define object-memory-reference (indexed-memory-reference (lambda (expression) expression false) - (index-locative-generator rtl:locative-offset 0 address-units-per-object))) + (index-locative-generator rtl:locative-offset + 0 + address-units-per-object + scfg*scfg->scfg!))) (define vector-memory-reference (indexed-memory-reference (lambda (expression) (rtl:make-fetch (rtl:locative-offset expression 0))) - (index-locative-generator rtl:locative-offset 1 address-units-per-object))) + (index-locative-generator rtl:locative-offset + 1 + address-units-per-object + scfg*scfg->scfg!))) (define string-memory-reference (indexed-memory-reference (lambda (expression) (rtl:make-fetch (rtl:locative-offset expression 1))) (index-locative-generator rtl:locative-byte-offset 2 - address-units-per-packed-char))) + address-units-per-packed-char + scfg*scfg->scfg!))) (define (rtl:length-fetch locative) (rtl:make-cons-non-pointer (rtl:make-machine-constant (ucode-type fixnum)) @@ -582,37 +590,166 @@ MIT in each case. |# (finish (rtl:make-eq-test (car expressions) (cadr expressions)))) '(0 1) false)) - + (define-open-coder/predicate 'OBJECT-TYPE? + (lambda (operands) + (let ((operand (rvalue-known-value (car operands)))) + (if (and operand + (rvalue/constant? operand) + (let ((value (constant-value operand))) + (and (exact-nonnegative-integer? value) + (back-end:< value scheme-type-limit)))) + (values (lambda (combination expressions finish) + combination + (let ((type (car expressions)) + (object (cadr expressions))) + (finish + (rtl:make-type-test (rtl:make-object->type object) + (rtl:constant-value type))))) + '(0 1) + false) + (values (lambda (combination expressions finish) + (let ((type (car expressions)) + (object (cadr expressions))) + (open-code:with-checks + combination + (list + (open-code:type-check type (ucode-type fixnum)) + (open-code:range-check type + (rtl:make-machine-constant + scheme-type-limit))) + (finish + (rtl:make-eq-test (rtl:make-object->datum type) + (rtl:make-object->type object))) + (lambda (expression) + (finish (rtl:make-true-test expression))) + 'OBJECT-TYPE? + expressions))) + '(0 1) + internal-close-coding-for-type-or-range-checks))))) + +(let ((open-coder + (simple-open-coder + (lambda (combination expressions finish) + combination + (finish + (rtl:make-cons-non-pointer + (rtl:make-machine-constant (ucode-type fixnum)) + (rtl:make-object->type (car expressions))))) + '(0) + false))) + (define-open-coder/value 'OBJECT-TYPE open-coder) + (define-open-coder/value 'PRIMITIVE-OBJECT-TYPE open-coder)) + +(define-open-coder/value 'PRIMITIVE-OBJECT-SET-TYPE + (filter/type-code + (lambda (type) + (lambda (combination expressions finish) + combination + (finish + (rtl:make-cons-non-pointer + (rtl:make-machine-constant type) + (rtl:make-object->datum (car expressions)))))) + 0 + '(1) + false)) + +(define-open-coder/value 'GET-INTERRUPT-ENABLES (simple-open-coder (lambda (combination expressions finish) - (let ((type (car expressions)) - (object (cadr expressions))) - (let* ((ok? (rtl:constant? type)) - (tag (and ok? - (rtl:constant-value type)))) - (if (and ok? - (exact-nonnegative-integer? tag) - (back-end:< tag scheme-type-limit)) - (finish - (rtl:make-type-test (rtl:make-object->type object) - tag)) - (open-code:with-checks - combination - (list - (open-code:type-check type (ucode-type fixnum)) - (open-code:range-check type - (rtl:make-machine-constant - scheme-type-limit))) - (finish - (rtl:make-eq-test (rtl:make-object->datum type) - (rtl:make-object->type object))) - (lambda (expression) - (finish (rtl:make-true-test expression))) - 'OBJECT-TYPE? - expressions))))) - '(0 1) + combination expressions + (finish (rtl:length-fetch register:int-mask))) + '() false)) + +(define-open-coder/effect 'SET-INTERRUPT-ENABLES! + (simple-open-coder + (lambda (combination expressions finish) + (let ((mask (car expressions))) + (open-code:with-checks + combination + (list (open-code:type-check mask (ucode-type fixnum))) + (let ((assignment + (rtl:make-assignment register:int-mask + (rtl:make-object->datum mask)))) + (if finish + (load-temporary-register scfg*scfg->scfg! + (rtl:length-fetch register:int-mask) + (lambda (temporary) + (scfg*scfg->scfg! assignment (finish temporary)))) + assignment)) + finish + 'SET-INTERRUPT-ENABLES! + expressions) + )) + '(0) + internal-close-coding-for-type-checks)) + +(define-open-coder/value 'PRIMITIVE-GET-FREE + (filter/type-code + (lambda (type) + (lambda (combination expressions finish) + combination expressions + (finish + (rtl:make-cons-pointer (rtl:make-machine-constant type) + (rtl:make-fetch register:free))))) + 0 + '() + false)) + +(define-open-coder/effect 'PRIMITIVE-INCREMENT-FREE + (simple-open-coder + (lambda (combination expressions finish) + (let ((length (car expressions))) + (open-code:with-checks + combination + (list (open-code:type-check length (ucode-type fixnum)) + (open-code:nonnegative-check length)) + (let ((assignment + ((index-locative-generator rtl:locative-offset + 0 + address-units-per-object + scfg*scfg->scfg!) + (rtl:make-fetch register:free) + length + (lambda (locative) + (rtl:make-assignment register:free + (rtl:make-address locative)))))) + (if finish + (scfg*scfg->scfg! assignment + (finish (rtl:make-constant unspecific))) + assignment)) + finish + 'PRIMITIVE-INCREMENT-FREE + expressions))) + '(0) + internal-close-coding-for-type-or-range-checks)) + +(define-open-coder/predicate 'HEAP-AVAILABLE? + (simple-open-coder + (lambda (combination expressions finish) + (let ((length (car expressions))) + (open-code:with-checks + combination + (list (open-code:type-check length (ucode-type fixnum)) + (open-code:nonnegative-check length)) + ((index-locative-generator rtl:locative-offset + 0 + address-units-per-object + scfg*pcfg->pcfg!) + (rtl:make-fetch register:free) + length + (lambda (locative) + (finish + (rtl:make-fixnum-pred-2-args + 'LESS-THAN-FIXNUM? + (rtl:make-address->fixnum (rtl:make-address locative)) + (rtl:make-address->fixnum (rtl:make-fetch register:memory-top)))))) + finish + 'PRIMITIVE-INCREMENT-FREE + expressions))) + '(0) + internal-close-coding-for-type-or-range-checks)) (let ((open-code/pair-cons (lambda (type) @@ -676,10 +813,11 @@ MIT in each case. |# (open-code:with-checks combination (list (open-code:nonnegative-check length)) - (finish - (rtl:make-typed-cons:string - (rtl:make-machine-constant (ucode-type string)) - length)) + (scfg*scfg->scfg! + (finish + (rtl:make-typed-cons:string + (rtl:make-machine-constant (ucode-type string)) + length))) finish 'STRING-ALLOCATE expressions))) @@ -695,9 +833,7 @@ MIT in each case. |# (let ((expression (car expressions))) (open-code:with-checks combination - (if type - (list (open-code:type-check expression type)) - '()) + (list (open-code:type-check expression type)) (finish (make-fetch (rtl:locative-offset expression index))) finish name @@ -707,7 +843,6 @@ MIT in each case. |# (user-ref 'CELL-CONTENTS rtl:make-fetch (ucode-type cell) 0) (user-ref 'VECTOR-LENGTH rtl:length-fetch (ucode-type vector) 0) (user-ref '%RECORD-LENGTH rtl:vector-length-fetch (ucode-type record) 0) - (user-ref 'SYSTEM-VECTOR-SIZE rtl:vector-length-fetch false 0) (user-ref 'STRING-LENGTH rtl:length-fetch (ucode-type string) 1) (user-ref 'BIT-STRING-LENGTH rtl:length-fetch (ucode-type vector-1b) 1) (user-ref 'CAR rtl:make-fetch (ucode-type pair) 0) @@ -727,34 +862,9 @@ MIT in each case. |# (system-ref 'SYSTEM-PAIR-CDR rtl:make-fetch 1) (system-ref 'SYSTEM-HUNK3-CXR0 rtl:make-fetch 0) (system-ref 'SYSTEM-HUNK3-CXR1 rtl:make-fetch 1) - (system-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch 2)) - -(let ((open-coder - (simple-open-coder - (lambda (combination expressions finish) - combination - (finish - (rtl:make-cons-non-pointer - (rtl:make-machine-constant (ucode-type fixnum)) - (rtl:make-object->type (car expressions))))) - '(0) - false))) - (define-open-coder/value 'OBJECT-TYPE open-coder) - (define-open-coder/value 'PRIMITIVE-OBJECT-TYPE open-coder)) + (system-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch 2) + (system-ref 'SYSTEM-VECTOR-SIZE rtl:vector-length-fetch 0)) -(define-open-coder/value 'PRIMITIVE-OBJECT-SET-TYPE - (filter/type-code - (lambda (type) - (lambda (combination expressions finish) - combination - (finish - (rtl:make-cons-non-pointer - (rtl:make-machine-constant type) - (rtl:make-object->datum (car expressions)))))) - 0 - '(1) - false)) - (let ((make-ref (lambda (name type) (define-open-coder/value name @@ -777,11 +887,7 @@ MIT in each case. |# (finish (rtl:make-fetch locative)))) '(0 1) false)) - -;; For now SYSTEM-XXXX side effect procedures are considered dangerous -;; to the garbage collector's health. Some day we will again be able -;; to enable them. - + (let ((fixed-assignment (lambda (name type index) (define-open-coder/effect name @@ -790,7 +896,7 @@ MIT in each case. |# (let ((object (car expressions))) (open-code:with-checks combination - (if type (list (open-code:type-check object type)) '()) + (list (open-code:type-check object type)) (finish-vector-assignment (rtl:locative-offset object index) (cadr expressions) finish) @@ -801,14 +907,26 @@ MIT in each case. |# 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-CELL-CONTENTS! (ucode-type cell) 0) - #| - (fixed-assignment 'SYSTEM-PAIR-SET-CAR! false 0) - (fixed-assignment 'SYSTEM-PAIR-SET-CDR! false 1) - (fixed-assignment 'SYSTEM-HUNK3-SET-CXR0! false 0) - (fixed-assignment 'SYSTEM-HUNK3-SET-CXR1! false 1) - (fixed-assignment 'SYSTEM-HUNK3-SET-CXR2! false 2) - |#) + (fixed-assignment 'SET-CELL-CONTENTS! (ucode-type cell) 0)) + +(define-open-coder/effect 'SET-STRING-LENGTH! + (simple-open-coder + (lambda (combination expressions finish) + (let ((object (car expressions)) + (length (cadr expressions))) + (open-code:with-checks + combination + (list (open-code:type-check object (ucode-type string)) + (open-code:type-check length (ucode-type fixnum)) + (open-code:nonnegative-check length)) + (finish-vector-assignment (rtl:locative-offset object 1) + (rtl:make-object->datum length) + finish) + finish + 'SET-STRING-LENGTH! + expressions))) + '(0 1) + internal-close-coding-for-type-or-range-checks)) (let ((make-assignment (lambda (name type) @@ -822,8 +940,7 @@ MIT in each case. |# '(0 1 2) internal-close-coding-for-type-or-range-checks))))) (make-assignment 'VECTOR-SET! (ucode-type vector)) - (make-assignment '%RECORD-SET! (ucode-type record)) - #|(make-assignment 'SYSTEM-VECTOR-SET! false)|#) + (make-assignment '%RECORD-SET! (ucode-type record))) (define-open-coder/effect 'PRIMITIVE-OBJECT-SET! (simple-open-coder @@ -1067,7 +1184,7 @@ MIT in each case. |# false))) '(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?)) -;;; Floating Point Arithmetic +;;;; Floating Point Arithmetic ;; On some machines, there are optional floating-point co-processors, ;; The decision of whether to open-code floating-point arithmetic or @@ -1173,7 +1290,7 @@ MIT in each case. |# internal-close-coding-for-type-checks))) '(FLONUM-EQUAL? FLONUM-LESS? FLONUM-GREATER?)) -;;; Generic arithmetic +;;;; Generic arithmetic (define (generic-binary-operator generic-op) (define-open-coder/value generic-op -- 2.25.1