From 786258f144827b74d331386567f32f890964cd6d Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Wed, 21 Apr 2010 22:26:19 -0500 Subject: [PATCH] Add the rest of the FP math primitives. Improve detection of unsimplified primitive forms. Also hides %goto-end-*. Automatically convert fixnum to FP in get_float(). (But not _get_float()!) --- compiler.ss | 218 +++++++++++++++++++++++++++++++--------------------- gc.c | 11 ++- 2 files changed, 140 insertions(+), 89 deletions(-) diff --git a/compiler.ss b/compiler.ss index fd921c9..24c0096 100755 --- a/compiler.ss +++ b/compiler.ss @@ -23,89 +23,134 @@ #f)) (define unary-value-primitives - '((%unbox . #x02) - (%car . #x03) - (%cdr . #x04) - (%boolean? . #x08) - (%fixnum? . #x09) - (%box? . #x0a) - (%pair? . #x0b) - (%vector? . #x0c) - (%byte-string? . #x0d) - (%struct? . #x0e) - (%float? . #x0f) - (%builtin? . #x10) - (%make-box . #x18) - (%make-struct . #x19) - (%make-float . #x1a) - (%make-lambda . #x1b) - (%not . #x20) - (%bit-not . #x21) - (%fix- . #x22) - (%float- . #x23) - (%vector-size . #x28) - (%byte-string-size . #x29) - (%struct-nslots . #x2a) - (%struct-type . #x2b) - ; add floating-point ops... - )) + '((%unbox #x02 unbox) + (%car #x03 car) + (%cdr #x04 cdr) + (%boolean? #x08 boolean?) + (%fixnum? #x09 fixnum?) + (%box? #x0a box?) + (%pair? #x0b pair?) + (%vector? #x0c vector?) + (%byte-string? #x0d byte-string?) + (%struct? #x0e struct?) + (%float? #x0f float?) + (%builtin? #x10 builtin?) + (%make-box #x18 make-box) + (%make-struct #x19 make-struct) + (%make-float #x1a make-float) + (%make-lambda #x1b make-lambda) + (%not #x20 not) + (%bit-not #x21 bit-not) + (%fix- #x22 fix-) + (%float- #x23 float-) + (%vector-size #x28 vector-size) + (%byte-string-size #x29 byte-string-size) + (%struct-nslots #x2a struct-nslots) + (%struct-type #x2b struct-type) + (%acos #x30 acos) + (%asin #x31 asin) + (%atan #x32 atan) + (%cos #x33 cos) + (%sin #x34 sin) + (%tan #x35 tan) + (%cosh #x36 cosh) + (%sinh #x37 sinh) + (%tanh #x38 tanh) + (%exp #x39 exp) + (%frexp #x3a frexp) + (%log #x3b log) + (%log10 #x3c log10) + (%modf #x3d modf) + (%sqrt #x3e sqrt) + (%ceil #x3f ceil) + (%fabs #x40 fabs) + (%floor #x41 floor) + (%erf #x50 erf) + (%erfc #x51 erfc) + (%j0 #x52 j0) + (%j1 #x53 j1) + (%lgamma #x54 lgamma) + (%y0 #x55 y0) + (%y1 #x56 y1) + (%asinh #x57 asinh) + (%acosh #x58 acosh) + (%atanh #x59 atanh) + (%cbrt #x5a cbrt) + (%logb #x5b logb) + (%expm1 #x5c expm1) + (%ilogb #x5d ilogb) + (%log1p #x5e log1p) + (%normal? #x70 normal?) + (%finite? #x71 finite?) + (%subnormal? #x72 subnormal?) + (%infinite? #x73 infinite?) + (%nan? #x74 nan?))) (define binary-value-primitives - '((%eq? . #x01) - (%cons . #x02) - (%make-vector . #x03) - (%make-byte-string . #x04) - (%vector-ref . #x05) - (%byte-string-ref . #x06) - (%struct-ref . #x07) - (%fix+ . #x08) - (%fix- . #x09) - (%fix* . #x0a) - (%fix/ . #x0b) - (%fix% . #x0c) - (%fix< . #x0d) - (%fix>= . #x0e) - (%bit-and . #x10) - (%bit-or . #x11) - (%bit-xor . #x12) - (%fix<< . #x14) - (%fix>> . #x15) - (%fix>>> . #x16) - (%float+ . #x18) - (%float- . #x19) - (%float* . #x1a) - (%float/ . #x1b) - (%float= . #x1c) - (%float< . #x1d) - (%float>= . #x1e) - ; add floating-point ops... - )) + '((%eq? #x01 eq?) + (%cons #x02 cons) + (%make-vector #x03 make-vector) + (%make-byte-string #x04 make-byte-string) + (%vector-ref #x05 vector-ref) + (%byte-string-ref #x06 byte-string-ref) + (%struct-ref #x07 struct-ref) + (%fix+ #x08 fix+) + (%fix- #x09 fix-) + (%fix* #x0a fix*) + (%fix/ #x0b fix/) + (%fix% #x0c fix%) + (%fix< #x0d fix<) + (%fix>= #x0e fix>=) + (%bit-and #x10 bit-and) + (%bit-or #x11 bit-or) + (%bit-xor #x12 bit-xor) + (%fix<< #x14 fix<<) + (%fix>> #x15 fix>>) + (%fix>>> #x16 fix>>>) + (%float+ #x18 float+) + (%float- #x19 float-) + (%float* #x1a float*) + (%float/ #x1b float/) + (%float= #x1c float=) + (%float< #x1d float<) + (%float>= #x1e float>=) + (%atan2 #x20 atan2) + (%pow #x21 pow) + (%ldexp #x22 ldexp) + (%fmod #x23 fmod) + (%hypot #x24 hypot) + (%jn #x25 jn) + (%yn #x26 yn) + (%nextafter #x27 nextafter) + (%remainder #x28 remainder) + (%scalb #x29 scalb))) (define unary-statement-primitives - '((%goto-end-if . #x40) - (%goto-end-unless . #x41))) + '((%goto-end-if #x40 #f) + (%goto-end-unless #x41 #f))) (define binary-statement-primitives - '((%set-box! . #x50) - (%set-car! . #x51) - (%set-cdr! . #x52))) + '((%set-box! #x50 set-box!) + (%set-car! #x51 set-car!) + (%set-cdr! #x52 set-cdr!))) (define ternary-statement-primitives - '((%vector-set! . #x60) - (%byte-string-set! . #x61) - (%struct-set! . #x62))) + '((%vector-set! #x60 vector-set!) + (%byte-string-set! #x61 byte-string-set!) + (%struct-set! #x62 struct-set!))) (define value-primitives - (append - (map car unary-value-primitives) - (map car binary-value-primitives) - (list '%if))) + (append unary-value-primitives + binary-value-primitives + (list '(%if #f #f)))) (define statement-primitives - (append - (map car unary-statement-primitives) - (map car binary-statement-primitives) - (map car ternary-statement-primitives))) + (append unary-statement-primitives + binary-statement-primitives + ternary-statement-primitives)) + +(define primitives + (append value-primitives statement-primitives)) (define (variable-value? form) (and (symbol? form) @@ -130,26 +175,23 @@ (define complex-values '(%bind %apply %call/cc %values)) (or (simple-value? form) (memq (first form) complex-values) - (memq (first form) value-primitives))) + (memq (first form) (map first value-primitives)))) ; A statement-form is any simple form which has, or may have, side-effects. (define (statement-form? form) (define complex-statements '(%set! %apply %call/cc %tail-call)) (and (not (simple-value? form)) (or (memq (first form) complex-statements) - (memq (first form) statement-primitives)))) + (memq (first form) (map first statement-primitives))))) + +(define (primitive-form? form) + (and (pair? form) (memq (first form) (map first primitives)))) ; A pure form is any form known to be free of side-effects. (define (pure-form? form) (and (value-form? form) (not (statement-form? form)))) -(define primitives - (append value-primitives statement-primitives)) - -(define (primitive-form? form) - (and (pair? form) (memq (first form) primitives))) - (define (bind-form? form) (and (pair? form) (eq? (first form) '%bind))) @@ -286,9 +328,11 @@ [(values) (simplify-primitive '%values (cdr form))] [(call/cc) (simplify-primitive '%call/cc (cdr form))] [else - (let ([primitive-name (string-append "%" (symbol->string (first form)))]) - (if (member primitive-name (map symbol->string primitives)) - (simplify-primitive (string->symbol primitive-name) (cdr form)) + (let ([primitive (memf (lambda (x) (eq? (third x) (first form))) + primitives)]) + (if primitive + (simplify-primitive (first (first primitive)) + (cdr form)) (simplify-funcall form)))])))) (define (form-sets? form variable [call-may-set? #t]) @@ -1077,10 +1121,10 @@ [(machine-var? value) (list #x00 out #x01 (variable->code value))] [(eq? (length (cdr value)) 1) - (list #x00 out (cdr (assoc (first value) unary-value-primitives)) + (list #x00 out (second (assoc (first value) unary-value-primitives)) (variable->code (second value)))] [(eq? (length (cdr value)) 2) - (list* (cdr (assoc (first value) binary-value-primitives)) + (list* (second (assoc (first value) binary-value-primitives)) out (map variable->code (cdr value)))] [else (unless (and (eq? (first value) '%if) @@ -1088,15 +1132,15 @@ (error "Unsupported ternary form:" form)) (list* out (map variable->code (cdr value)))])) (case (length (cdr form)) - [(1) (list (cdr (assoc (first form) unary-statement-primitives)) + [(1) (list (second (assoc (first form) unary-statement-primitives)) (variable->code (second form)) #x00 #x00)] - [(2) (list (cdr (assoc (first form) binary-statement-primitives)) + [(2) (list (second (assoc (first form) binary-statement-primitives)) (variable->code (second form)) (variable->code (third form)) #x00)] - [(3) (list (cdr (assoc (first form) ternary-statement-primitives)) + [(3) (list (second (assoc (first form) ternary-statement-primitives)) (variable->code (second form)) (variable->code (third form)) (variable->code (fourth form)))] diff --git a/gc.c b/gc.c index addb35d..29a0382 100644 --- a/gc.c +++ b/gc.c @@ -315,8 +315,15 @@ value_t make_float(native_float_t value) native_float_t get_float(value_t v) { - release_assert(is_float(v)); - return _get_float(v); + if (is_fixnum(v)) + { + return (native_float_t)_get_fixnum(v); + } + else + { + release_assert(is_float(v)); + return _get_float(v); + } } value_t make_builtin_fn(builtin_fn_t *fn)