nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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()!)
This commit is contained in:
Jesse D. McDonald 2010-04-21 22:26:19 -05:00
parent 67ea700ac2
commit 786258f144
2 changed files with 140 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

218
compiler.ss
View File

@ -23,89 +23,134 @@
#f)) #f))
(define unary-value-primitives (define unary-value-primitives
'((%unbox . #x02) '((%unbox #x02 unbox)
(%car . #x03) (%car #x03 car)
(%cdr . #x04) (%cdr #x04 cdr)
(%boolean? . #x08) (%boolean? #x08 boolean?)
(%fixnum? . #x09) (%fixnum? #x09 fixnum?)
(%box? . #x0a) (%box? #x0a box?)
(%pair? . #x0b) (%pair? #x0b pair?)
(%vector? . #x0c) (%vector? #x0c vector?)
(%byte-string? . #x0d) (%byte-string? #x0d byte-string?)
(%struct? . #x0e) (%struct? #x0e struct?)
(%float? . #x0f) (%float? #x0f float?)
(%builtin? . #x10) (%builtin? #x10 builtin?)
(%make-box . #x18) (%make-box #x18 make-box)
(%make-struct . #x19) (%make-struct #x19 make-struct)
(%make-float . #x1a) (%make-float #x1a make-float)
(%make-lambda . #x1b) (%make-lambda #x1b make-lambda)
(%not . #x20) (%not #x20 not)
(%bit-not . #x21) (%bit-not #x21 bit-not)
(%fix- . #x22) (%fix- #x22 fix-)
(%float- . #x23) (%float- #x23 float-)
(%vector-size . #x28) (%vector-size #x28 vector-size)
(%byte-string-size . #x29) (%byte-string-size #x29 byte-string-size)
(%struct-nslots . #x2a) (%struct-nslots #x2a struct-nslots)
(%struct-type . #x2b) (%struct-type #x2b struct-type)
; add floating-point ops... (%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 (define binary-value-primitives
'((%eq? . #x01) '((%eq? #x01 eq?)
(%cons . #x02) (%cons #x02 cons)
(%make-vector . #x03) (%make-vector #x03 make-vector)
(%make-byte-string . #x04) (%make-byte-string #x04 make-byte-string)
(%vector-ref . #x05) (%vector-ref #x05 vector-ref)
(%byte-string-ref . #x06) (%byte-string-ref #x06 byte-string-ref)
(%struct-ref . #x07) (%struct-ref #x07 struct-ref)
(%fix+ . #x08) (%fix+ #x08 fix+)
(%fix- . #x09) (%fix- #x09 fix-)
(%fix* . #x0a) (%fix* #x0a fix*)
(%fix/ . #x0b) (%fix/ #x0b fix/)
(%fix% . #x0c) (%fix% #x0c fix%)
(%fix< . #x0d) (%fix< #x0d fix<)
(%fix>= . #x0e) (%fix>= #x0e fix>=)
(%bit-and . #x10) (%bit-and #x10 bit-and)
(%bit-or . #x11) (%bit-or #x11 bit-or)
(%bit-xor . #x12) (%bit-xor #x12 bit-xor)
(%fix<< . #x14) (%fix<< #x14 fix<<)
(%fix>> . #x15) (%fix>> #x15 fix>>)
(%fix>>> . #x16) (%fix>>> #x16 fix>>>)
(%float+ . #x18) (%float+ #x18 float+)
(%float- . #x19) (%float- #x19 float-)
(%float* . #x1a) (%float* #x1a float*)
(%float/ . #x1b) (%float/ #x1b float/)
(%float= . #x1c) (%float= #x1c float=)
(%float< . #x1d) (%float< #x1d float<)
(%float>= . #x1e) (%float>= #x1e float>=)
; add floating-point ops... (%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 (define unary-statement-primitives
'((%goto-end-if . #x40) '((%goto-end-if #x40 #f)
(%goto-end-unless . #x41))) (%goto-end-unless #x41 #f)))
(define binary-statement-primitives (define binary-statement-primitives
'((%set-box! . #x50) '((%set-box! #x50 set-box!)
(%set-car! . #x51) (%set-car! #x51 set-car!)
(%set-cdr! . #x52))) (%set-cdr! #x52 set-cdr!)))
(define ternary-statement-primitives (define ternary-statement-primitives
'((%vector-set! . #x60) '((%vector-set! #x60 vector-set!)
(%byte-string-set! . #x61) (%byte-string-set! #x61 byte-string-set!)
(%struct-set! . #x62))) (%struct-set! #x62 struct-set!)))
(define value-primitives (define value-primitives
(append (append unary-value-primitives
(map car unary-value-primitives) binary-value-primitives
(map car binary-value-primitives) (list '(%if #f #f))))
(list '%if)))
(define statement-primitives (define statement-primitives
(append (append unary-statement-primitives
(map car unary-statement-primitives) binary-statement-primitives
(map car binary-statement-primitives) ternary-statement-primitives))
(map car ternary-statement-primitives)))
(define primitives
(append value-primitives statement-primitives))
(define (variable-value? form) (define (variable-value? form)
(and (symbol? form) (and (symbol? form)
@ -130,26 +175,23 @@
(define complex-values '(%bind %apply %call/cc %values)) (define complex-values '(%bind %apply %call/cc %values))
(or (simple-value? form) (or (simple-value? form)
(memq (first form) complex-values) (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. ; A statement-form is any simple form which has, or may have, side-effects.
(define (statement-form? form) (define (statement-form? form)
(define complex-statements '(%set! %apply %call/cc %tail-call)) (define complex-statements '(%set! %apply %call/cc %tail-call))
(and (not (simple-value? form)) (and (not (simple-value? form))
(or (memq (first form) complex-statements) (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. ; A pure form is any form known to be free of side-effects.
(define (pure-form? form) (define (pure-form? form)
(and (value-form? form) (and (value-form? form)
(not (statement-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) (define (bind-form? form)
(and (pair? form) (eq? (first form) '%bind))) (and (pair? form) (eq? (first form) '%bind)))
@ -286,9 +328,11 @@
[(values) (simplify-primitive '%values (cdr form))] [(values) (simplify-primitive '%values (cdr form))]
[(call/cc) (simplify-primitive '%call/cc (cdr form))] [(call/cc) (simplify-primitive '%call/cc (cdr form))]
[else [else
(let ([primitive-name (string-append "%" (symbol->string (first form)))]) (let ([primitive (memf (lambda (x) (eq? (third x) (first form)))
(if (member primitive-name (map symbol->string primitives)) primitives)])
(simplify-primitive (string->symbol primitive-name) (cdr form)) (if primitive
(simplify-primitive (first (first primitive))
(cdr form))
(simplify-funcall form)))])))) (simplify-funcall form)))]))))
(define (form-sets? form variable [call-may-set? #t]) (define (form-sets? form variable [call-may-set? #t])
@ -1077,10 +1121,10 @@
[(machine-var? value) [(machine-var? value)
(list #x00 out #x01 (variable->code value))] (list #x00 out #x01 (variable->code value))]
[(eq? (length (cdr value)) 1) [(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)))] (variable->code (second value)))]
[(eq? (length (cdr value)) 2) [(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)))] out (map variable->code (cdr value)))]
[else [else
(unless (and (eq? (first value) '%if) (unless (and (eq? (first value) '%if)
@ -1088,15 +1132,15 @@
(error "Unsupported ternary form:" form)) (error "Unsupported ternary form:" form))
(list* out (map variable->code (cdr value)))])) (list* out (map variable->code (cdr value)))]))
(case (length (cdr form)) (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)) (variable->code (second form))
#x00 #x00
#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 (second form))
(variable->code (third form)) (variable->code (third form))
#x00)] #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 (second form))
(variable->code (third form)) (variable->code (third form))
(variable->code (fourth form)))] (variable->code (fourth form)))]

11
gc.c
View File

@ -315,8 +315,15 @@ value_t make_float(native_float_t value)
native_float_t get_float(value_t v) native_float_t get_float(value_t v)
{ {
release_assert(is_float(v)); if (is_fixnum(v))
return _get_float(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) value_t make_builtin_fn(builtin_fn_t *fn)