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

Refactor (define) parser to work in (let), (lambda), (begin), etc. 

Add support for (fix=), (list), (and), (or), (cond), (when), and (unless).
Fix a mapper bug which could assign the same frame var to separate variables.
Update make-struct primitive for new structure type layout.
Change primitives to use #% as prefix instead of just %.
Add primitive operations for comparing byte-strings.
This commit is contained in:
Jesse D. McDonald 2010-05-25 22:36:04 -05:00
parent 061364c75c
commit 9e4286b49e
13 changed files with 411 additions and 326 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
builtin.c
View File

@ -97,7 +97,7 @@ static void register_structure(void)
/* Slot 1: List of superclasses, most to least specific */ /* Slot 1: List of superclasses, most to least specific */
_get_struct(structure_type_root.value)->slots[SS(SUPERS)] = NIL; _get_struct(structure_type_root.value)->slots[SS(SUPERS)] = NIL;
/* Slot 2: Total number of slots (excl. type) */ /* Slot 2: Total number of slots (excl. type) */
_get_struct(structure_type_root.value)->slots[SS(SLOTS)] = fixnum_value(STRUCTURE_SLOTS); _get_struct(structure_type_root.value)->slots[SS(NSLOTS)] = fixnum_value(STRUCTURE_SLOTS);
/* Slot 3: Callable object used as proxy when structure is APPLY'd. */ /* Slot 3: Callable object used as proxy when structure is APPLY'd. */
/* Can be LAMBDA, callable structure instance, builtin, or FALSE_VALUE. */ /* Can be LAMBDA, callable structure instance, builtin, or FALSE_VALUE. */
_get_struct(structure_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE; _get_struct(structure_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
@ -114,7 +114,7 @@ static void register_template(void)
/* Slot 1: List of superclasses, most to least specific */ /* Slot 1: List of superclasses, most to least specific */
_get_struct(template_type_root.value)->slots[SS(SUPERS)] = NIL; _get_struct(template_type_root.value)->slots[SS(SUPERS)] = NIL;
/* Slot 2: Total number of slots (excl. type) */ /* Slot 2: Total number of slots (excl. type) */
_get_struct(template_type_root.value)->slots[SS(SLOTS)] = fixnum_value(TEMPLATE_SLOTS); _get_struct(template_type_root.value)->slots[SS(NSLOTS)] = fixnum_value(TEMPLATE_SLOTS);
/* Slot 3: Callable object used as proxy when structure is APPLY'd. */ /* Slot 3: Callable object used as proxy when structure is APPLY'd. */
_get_struct(template_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE; _get_struct(template_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
@ -129,7 +129,7 @@ static void register_lambda(void)
/* Slot 1: List of superclasses, most to least specific */ /* Slot 1: List of superclasses, most to least specific */
_get_struct(lambda_type_root.value)->slots[SS(SUPERS)] = NIL; _get_struct(lambda_type_root.value)->slots[SS(SUPERS)] = NIL;
/* Slot 2: Total number of slots (excl. type) */ /* Slot 2: Total number of slots (excl. type) */
_get_struct(lambda_type_root.value)->slots[SS(SLOTS)] = fixnum_value(LAMBDA_SLOTS); _get_struct(lambda_type_root.value)->slots[SS(NSLOTS)] = fixnum_value(LAMBDA_SLOTS);
/* Slot 3: Callable object used as proxy when structure is APPLY'd. */ /* Slot 3: Callable object used as proxy when structure is APPLY'd. */
_get_struct(lambda_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE; _get_struct(lambda_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;

2
builtin.h
View File

@ -24,7 +24,7 @@
#define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s]) #define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s])
#define STRUCTURE_SLOT_SUPERS 0 #define STRUCTURE_SLOT_SUPERS 0
#define STRUCTURE_SLOT_SLOTS 1 #define STRUCTURE_SLOT_NSLOTS 1
#define STRUCTURE_SLOT_CALLABLE 2 #define STRUCTURE_SLOT_CALLABLE 2
#define STRUCTURE_SLOTS 3 #define STRUCTURE_SLOTS 3

5
doc/bytecode.txt
View File

@ -135,7 +135,10 @@ binary-expr: up to 63 (01..3f), 1 out, 2 in
28 (set! out (remainder in1 in2)) ; float float 28 (set! out (remainder in1 in2)) ; float float
29 (set! out (scalb in1 in2)) ; float float 29 (set! out (scalb in1 in2)) ; float float
30 (set! out (kind-of? in1 in2)) ; value struct-type 30 (set! out (kind-of? in1 in2)) ; value struct-type
31 (set! out (byte-string= in1 in2))
32 (set! out (byte-string< in1 in2)) ; == (byte-string> in2 in1)
33 (set! out (byte-string>= in1 in2)) ; == (byte-string<= in2 in1)
conditional: 1 out, 3 in conditional: 1 out, 3 in
; 0x80 <= AA <= 0xf7 (f0-f119) ; 0x80 <= AA <= 0xf7 (f0-f119)
AA (set! AA (if in1 in2 in3)) ; in3 if in1 == #f, in2 otherwise AA (set! AA (if in1 in2 in3)) ; in3 if in1 == #f, in2 otherwise

21
interp.c
View File

@ -34,6 +34,8 @@ static void vector_set(value_t v, fixnum_t idx, value_t newval);
static void byte_string_set(value_t v, fixnum_t idx, char newval); static void byte_string_set(value_t v, fixnum_t idx, char newval);
static void struct_set(value_t v, fixnum_t idx, value_t newval); static void struct_set(value_t v, fixnum_t idx, value_t newval);
static int byte_string_cmp(value_t s1, value_t s2);
static value_t make_lambda(interp_state_t *state, value_t templ); static value_t make_lambda(interp_state_t *state, value_t templ);
static void translate_callable(interp_state_t *state); static void translate_callable(interp_state_t *state);
@ -183,6 +185,16 @@ static void struct_set(value_t v, fixnum_t idx, value_t newval)
WRITE_BARRIER(v); WRITE_BARRIER(v);
} }
static int byte_string_cmp(value_t s1, value_t s2)
{
byte_string_t *str1 = get_byte_string(s1);
byte_string_t *str2 = get_byte_string(s2);
if (str1->size < str2->size) return -1;
else if (str1->size > str2->size) return 1;
else return memcmp(str1->bytes, str2->bytes, str1->size);
}
static value_t make_lambda(interp_state_t *state, value_t templ) static value_t make_lambda(interp_state_t *state, value_t templ)
{ {
gc_root_t templ_root, lambda_root; gc_root_t templ_root, lambda_root;
@ -365,6 +377,9 @@ static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1,
case 0x28: return make_float(remainder(get_float(ST1), get_float(ST2))); case 0x28: return make_float(remainder(get_float(ST1), get_float(ST2)));
case 0x29: return make_float(scalb(get_float(ST1), get_float(ST2))); case 0x29: return make_float(scalb(get_float(ST1), get_float(ST2)));
case 0x30: return boolean_value(struct_is_a(ST1, ST2)); case 0x30: return boolean_value(struct_is_a(ST1, ST2));
case 0x31: return boolean_value(byte_string_cmp(ST1, ST2) == 0);
case 0x32: return boolean_value(byte_string_cmp(ST1, ST2) < 0);
case 0x33: return boolean_value(byte_string_cmp(ST1, ST2) >= 0);
default: release_assert(NOTREACHED("Invalid byte-code!")); default: release_assert(NOTREACHED("Invalid byte-code!"));
} }
@ -393,10 +408,10 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uin
case 0x10: return boolean_value(is_builtin_fn(ST1)); case 0x10: return boolean_value(is_builtin_fn(ST1));
case 0x18: return make_box(ST1); case 0x18: return make_box(ST1);
case 0x19: { case 0x19: {
vector_t *vec; fixnum_t nslots;
release_assert(struct_is_a(ST1, get_structure_type())); release_assert(struct_is_a(ST1, get_structure_type()));
vec = get_vector(_SLOT_VALUE(STRUCTURE, ST1, SLOTS)); nslots = get_fixnum(_SLOT_VALUE(STRUCTURE, ST1, NSLOTS));
return make_struct(ST1, vec->size); return make_struct(ST1, nslots);
} }
case 0x1a: return make_float((native_float_t)get_fixnum(ST1)); case 0x1a: return make_float((native_float_t)get_fixnum(ST1));
case 0x1b: return make_lambda(state, ST1); case 0x1b: return make_lambda(state, ST1);

14
libcompiler/mapper.scm
View File

@ -29,22 +29,26 @@
[inst-var (in-list instance-variables)]) [inst-var (in-list instance-variables)])
(set! i-vars (append i-vars (list free-var))) (set! i-vars (append i-vars (list free-var)))
(list free-var inst-var))]) (list free-var inst-var))])
(set! bind (subst-var* var-map bind))) (define (sv* form) (subst-var* var-map form))
(set! bind `(#%bind ,(subst* var-map (second bind))
,@(map sv* (cddr bind)))))
(for ([bound-var (in-list (second bind))] (for ([bound-var (in-list (second bind))]
[frame-var (in-list frame-variables)]) [frame-var (in-list frame-variables)])
(set! bind (subst-var bound-var frame-var bind))) (define (sv form) (subst-var bound-var frame-var form))
(set! bind `(#%bind ,(subst bound-var frame-var (second bind))
,@(map sv (cddr bind)))))
(set! bind (map-form bind (set! bind (map-form bind
#:lambda (lambda (recurse op inner-g-vars i-vars bind) #:lambda (lambda (recurse op inner-g-vars i-vars bind)
`(%make-lambda ,((compose add-g-var map-variables) `(#%make-lambda ,((compose add-g-var map-variables)
`(%template ,inner-g-vars ,i-vars ,bind)))) `(#%template ,inner-g-vars ,i-vars ,bind))))
#:variable (lambda (recurse kind form) #:variable (lambda (recurse kind form)
(if (machine-variable? form) form (add-g-var form))) (if (machine-variable? form) form (add-g-var form)))
#:literal (lambda (recurse kind form) #:literal (lambda (recurse kind form)
(if (eq? form '%nil) form (add-g-var form))))) (if (eq? form '%nil) form (add-g-var form)))))
`(,(if (null? i-vars) '%lambda '%template) ,g-vars ,i-vars `(,(if (null? i-vars) '#%lambda '#%template) ,g-vars ,i-vars
,bind))) ,bind)))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab:

56
libcompiler/optimizer.scm
View File

@ -21,7 +21,7 @@
(let* ([reduced-forms (map recurse subforms)] (let* ([reduced-forms (map recurse subforms)]
[ref-vars (remove-duplicates (append-map free-variables reduced-forms))]) [ref-vars (remove-duplicates (append-map free-variables reduced-forms))])
(define (referenced? var) (and (memq var ref-vars) #t)) (define (referenced? var) (and (memq var ref-vars) #t))
`(%bind ,(filter referenced? vars) `(#%bind ,(filter referenced? vars)
,@reduced-forms))) ,@reduced-forms)))
(map-form form #:bind bind-fn)) (map-form form #:bind bind-fn))
@ -30,13 +30,13 @@
(define (bind-fn recurse op vars . subforms) (define (bind-fn recurse op vars . subforms)
(define (prepend-if-used subform after) (define (prepend-if-used subform after)
(if (and (pair? subform) (if (and (pair? subform)
(eq? (first subform) '%set!) (eq? (first subform) '#%set!)
(or (memq (second subform) vars) (or (memq (second subform) vars)
(error "Setting unbound (constant) variable:" subform)) (error "Setting unbound (constant) variable:" subform))
(not (value-used? (second subform) after))) (not (value-used? (second subform) after)))
after after
(cons subform after))) (cons subform after)))
`(%bind ,vars `(#%bind ,vars
,@(foldr prepend-if-used '() (map recurse subforms)))) ,@(foldr prepend-if-used '() (map recurse subforms))))
(map-form form #:bind bind-fn)) (map-form form #:bind bind-fn))
@ -46,79 +46,79 @@
(let* ([form (car forms)] (let* ([form (car forms)]
[after (cdr forms)] [after (cdr forms)]
[new-form (case (first form) [new-form (case (first form)
[(%set!) (if (eq? (third form) variable) [(#%set!) (if (eq? (third form) variable)
`(%set! ,(second form) ,value) `(#%set! ,(second form) ,value)
form)] form)]
[else form])]) [else form])])
(if (or (and (eq? (first (car forms)) '%set!) (if (or (and (eq? (first (car forms)) '#%set!)
(eq? (second (car forms)) variable)) (eq? (second (car forms)) variable))
(invalidates? new-form)) (invalidates? new-form))
(cons new-form after) (cons new-form after)
(cons new-form (propogate-value variable value invalidates? after)))))) (cons new-form (propogate-value variable value invalidates? after))))))
; Simple values (literals, variables) can replace arguments as well as %set! values. ; Simple values (literals, variables) can replace arguments as well as #%set! values.
(define (propogate-simple-value variable value invalidates? forms) (define (propogate-simple-value variable value invalidates? forms)
(if (null? forms) (if (null? forms)
forms forms
(let* ([form (car forms)] (let* ([form (car forms)]
[after (cdr forms)] [after (cdr forms)]
[new-form (case (first form) [new-form (case (first form)
[(%set!) [(#%set!)
(let ([set-value (if (eq? (third form) variable) value (third form))]) (let ([set-value (if (eq? (third form) variable) value (third form))])
(if (simple-value? set-value) (if (simple-value? set-value)
`(%set! ,(second form) ,set-value) `(#%set! ,(second form) ,set-value)
`(%set! ,(second form) `(#%set! ,(second form)
(,(first set-value) (,(first set-value)
,@(subst variable value (cdr set-value))))))] ,@(subst variable value (cdr set-value))))))]
[else `(,(first form) ,@(subst variable value (cdr form)))])]) [else `(,(first form) ,@(subst variable value (cdr form)))])])
(if (or (and (eq? (first (car forms)) '%set!) (if (or (and (eq? (first (car forms)) '#%set!)
(eq? (second (car forms)) variable)) (eq? (second (car forms)) variable))
(invalidates? new-form)) (invalidates? new-form))
(cons new-form after) (cons new-form after)
(cons new-form (propogate-simple-value variable value invalidates? after)))))) (cons new-form (propogate-simple-value variable value invalidates? after))))))
; When value of var2 is known, change (%set! var1 var2) to (%set! var1 value). ; When value of var2 is known, change (#%set! var1 var2) to (#%set! var1 value).
; Known values are: ; Known values are:
; literals, always ; literals, always
; var, until (%set! var ...) ; var, until (#%set! var ...)
; (%unbox var), until (%set-box! ...) or (%set! var) ; (#%unbox var), until (#%set-box! ...) or (#%set! var)
; (%car var), until (%set-car! ...) or (%set! var) ; (#%car var), until (#%set-car! ...) or (#%set! var)
; (%cdr var), until (%set-cdr! ...) or (%set! var) ; (#%cdr var), until (#%set-cdr! ...) or (#%set! var)
(define (propogate-set! form) (define (propogate-set! form)
(define (bind-fn recurse op vars . subforms) (define (bind-fn recurse op vars . subforms)
(define (prepend subform after) (define (prepend subform after)
(cons (cons
subform subform
(match subform (match subform
[`(%set! ,var ,(? simple-value? value)) [`(#%set! ,var ,(? simple-value? value))
(propogate-simple-value var value (propogate-simple-value var value
(lambda (form) (lambda (form)
(and (eq? (first form) '%set!) (and (eq? (first form) '#%set!)
(eq? (second form) value))) (eq? (second form) value)))
after)] after)]
[`(%set! ,var ,(and value `(%unbox ,box-var))) [`(#%set! ,var ,(and value `(#%unbox ,box-var)))
(propogate-value var value (propogate-value var value
(lambda (form) (lambda (form)
(or (and (eq? (first form) '%set!) (or (and (eq? (first form) '#%set!)
(eq? (second form) box-var)) (eq? (second form) box-var))
(eq? (first form) '%set-box!))) (eq? (first form) '#%set-box!)))
after)] after)]
[`(%set! ,var ,(and value `(%car ,pair-var))) [`(#%set! ,var ,(and value `(#%car ,pair-var)))
(propogate-value var value (propogate-value var value
(lambda (form) (lambda (form)
(or (and (eq? (first form) '%set!) (or (and (eq? (first form) '#%set!)
(eq? (second form) pair-var)) (eq? (second form) pair-var))
(eq? (first form) '%set-car!))) (eq? (first form) '#%set-car!)))
after)] after)]
[`(%set! ,var ,(and value `(%cdr ,pair-var))) [`(#%set! ,var ,(and value `(#%cdr ,pair-var)))
(propogate-value var value (propogate-value var value
(lambda (form) (lambda (form)
(or (and (eq? (first form) '%set!) (or (and (eq? (first form) '#%set!)
(eq? (second form) pair-var)) (eq? (second form) pair-var))
(eq? (first form) '%set-cdr!))) (eq? (first form) '#%set-cdr!)))
after)] after)]
[_ after]))) [_ after])))
`(%bind ,vars `(#%bind ,vars
,@(foldr prepend '() (map recurse subforms)))) ,@(foldr prepend '() (map recurse subforms))))
(map-form form #:bind bind-fn)) (map-form form #:bind bind-fn))

231
libcompiler/primitives.scm
View File

@ -20,128 +20,131 @@
machine-variable?) machine-variable?)
(define unary-value-primitives (define unary-value-primitives
'((%unbox #x02 unbox) '((#%unbox #x02 unbox)
(%car #x03 car) (#%car #x03 car)
(%cdr #x04 cdr) (#%cdr #x04 cdr)
(%boolean? #x08 boolean?) (#%boolean? #x08 boolean?)
(%fixnum? #x09 fixnum?) (#%fixnum? #x09 fixnum?)
(%box? #x0a box?) (#%box? #x0a box?)
(%pair? #x0b pair?) (#%pair? #x0b pair?)
(%vector? #x0c vector?) (#%vector? #x0c vector?)
(%byte-string? #x0d byte-string?) (#%byte-string? #x0d byte-string?)
(%struct? #x0e struct?) (#%struct? #x0e struct?)
(%float? #x0f float?) (#%float? #x0f float?)
(%builtin? #x10 builtin?) (#%builtin? #x10 builtin?)
(%make-box #x18 make-box) (#%make-box #x18 make-box)
(%make-struct #x19 make-struct) (#%make-struct #x19 make-struct)
(%make-float #x1a make-float) (#%make-float #x1a make-float)
(%make-lambda #x1b make-lambda) (#%make-lambda #x1b make-lambda)
(%not #x20 not) (#%not #x20 not)
(%bit-not #x21 bit-not) (#%bit-not #x21 bit-not)
(%fix- #x22 fix-) (#%fix- #x22 fix-)
(%float- #x23 float-) (#%float- #x23 float-)
(%vector-size #x28 vector-size) (#%vector-size #x28 vector-size)
(%byte-string-size #x29 byte-string-size) (#%byte-string-size #x29 byte-string-size)
(%struct-nslots #x2a struct-nslots) (#%struct-nslots #x2a struct-nslots)
(%struct-type #x2b struct-type) (#%struct-type #x2b struct-type)
(%hash-value #x2c hash-value) (#%hash-value #x2c hash-value)
(%acos #x30 acos) (#%acos #x30 acos)
(%asin #x31 asin) (#%asin #x31 asin)
(%atan #x32 atan) (#%atan #x32 atan)
(%cos #x33 cos) (#%cos #x33 cos)
(%sin #x34 sin) (#%sin #x34 sin)
(%tan #x35 tan) (#%tan #x35 tan)
(%cosh #x36 cosh) (#%cosh #x36 cosh)
(%sinh #x37 sinh) (#%sinh #x37 sinh)
(%tanh #x38 tanh) (#%tanh #x38 tanh)
(%exp #x39 exp) (#%exp #x39 exp)
(%frexp #x3a frexp) (#%frexp #x3a frexp)
(%log #x3b log) (#%log #x3b log)
(%log10 #x3c log10) (#%log10 #x3c log10)
(%modf #x3d modf) (#%modf #x3d modf)
(%sqrt #x3e sqrt) (#%sqrt #x3e sqrt)
(%ceil #x3f ceil) (#%ceil #x3f ceil)
(%fabs #x40 fabs) (#%fabs #x40 fabs)
(%floor #x41 floor) (#%floor #x41 floor)
(%erf #x50 erf) (#%erf #x50 erf)
(%erfc #x51 erfc) (#%erfc #x51 erfc)
(%j0 #x52 j0) (#%j0 #x52 j0)
(%j1 #x53 j1) (#%j1 #x53 j1)
(%lgamma #x54 lgamma) (#%lgamma #x54 lgamma)
(%y0 #x55 y0) (#%y0 #x55 y0)
(%y1 #x56 y1) (#%y1 #x56 y1)
(%asinh #x57 asinh) (#%asinh #x57 asinh)
(%acosh #x58 acosh) (#%acosh #x58 acosh)
(%atanh #x59 atanh) (#%atanh #x59 atanh)
(%cbrt #x5a cbrt) (#%cbrt #x5a cbrt)
(%logb #x5b logb) (#%logb #x5b logb)
(%expm1 #x5c expm1) (#%expm1 #x5c expm1)
(%ilogb #x5d ilogb) (#%ilogb #x5d ilogb)
(%log1p #x5e log1p) (#%log1p #x5e log1p)
(%normal? #x70 normal?) (#%normal? #x70 normal?)
(%finite? #x71 finite?) (#%finite? #x71 finite?)
(%subnormal? #x72 subnormal?) (#%subnormal? #x72 subnormal?)
(%infinite? #x73 infinite?) (#%infinite? #x73 infinite?)
(%nan? #x74 nan?))) (#%nan? #x74 nan?)))
(define binary-value-primitives (define binary-value-primitives
'((%eq? #x01 eq?) '((#%eq? #x01 eq?)
(%cons #x02 cons) (#%cons #x02 cons)
(%make-vector #x03 make-vector) (#%make-vector #x03 make-vector)
(%make-byte-string #x04 make-byte-string) (#%make-byte-string #x04 make-byte-string)
(%vector-ref #x05 vector-ref) (#%vector-ref #x05 vector-ref)
(%byte-string-ref #x06 byte-string-ref) (#%byte-string-ref #x06 byte-string-ref)
(%struct-ref #x07 struct-ref) (#%struct-ref #x07 struct-ref)
(%fix+ #x08 fix+) (#%fix+ #x08 fix+)
(%fix- #x09 fix-) (#%fix- #x09 fix-)
(%fix* #x0a fix*) (#%fix* #x0a fix*)
(%fix/ #x0b fix/) (#%fix/ #x0b fix/)
(%fix% #x0c fix%) (#%fix% #x0c fix%)
(%fix< #x0d fix<) (#%fix< #x0d fix<)
(%fix>= #x0e fix>=) (#%fix>= #x0e fix>=)
(%bit-and #x10 bit-and) (#%bit-and #x10 bit-and)
(%bit-or #x11 bit-or) (#%bit-or #x11 bit-or)
(%bit-xor #x12 bit-xor) (#%bit-xor #x12 bit-xor)
(%fix<< #x14 fix<<) (#%fix<< #x14 fix<<)
(%fix>> #x15 fix>>) (#%fix>> #x15 fix>>)
(%fix>>> #x16 fix>>>) (#%fix>>> #x16 fix>>>)
(%float+ #x18 float+) (#%float+ #x18 float+)
(%float- #x19 float-) (#%float- #x19 float-)
(%float* #x1a float*) (#%float* #x1a float*)
(%float/ #x1b float/) (#%float/ #x1b float/)
(%float= #x1c float=) (#%float= #x1c float=)
(%float< #x1d float<) (#%float< #x1d float<)
(%float>= #x1e float>=) (#%float>= #x1e float>=)
(%atan2 #x20 atan2) (#%atan2 #x20 atan2)
(%pow #x21 pow) (#%pow #x21 pow)
(%ldexp #x22 ldexp) (#%ldexp #x22 ldexp)
(%fmod #x23 fmod) (#%fmod #x23 fmod)
(%hypot #x24 hypot) (#%hypot #x24 hypot)
(%jn #x25 jn) (#%jn #x25 jn)
(%yn #x26 yn) (#%yn #x26 yn)
(%nextafter #x27 nextafter) (#%nextafter #x27 nextafter)
(%remainder #x28 remainder) (#%remainder #x28 remainder)
(%scalb #x29 scalb) (#%scalb #x29 scalb)
(%kind-of? #x30 kind-of?))) (#%kind-of? #x30 kind-of?)
(#%byte-string= #x31 byte-string=)
(#%byte-string< #x32 byte-string<)
(#%byte-string>= #x33 byte-string>=)))
(define unary-statement-primitives (define unary-statement-primitives
'((%goto-end-if #x40 #f) '((#%goto-end-if #x40 #f)
(%goto-end-unless #x41 #f))) (#%goto-end-unless #x41 #f)))
(define binary-statement-primitives (define binary-statement-primitives
'((%set-box! #x50 set-box!) '((#%set-box! #x50 set-box!)
(%set-car! #x51 set-car!) (#%set-car! #x51 set-car!)
(%set-cdr! #x52 set-cdr!))) (#%set-cdr! #x52 set-cdr!)))
(define ternary-statement-primitives (define ternary-statement-primitives
'((%vector-set! #x60 vector-set!) '((#%vector-set! #x60 vector-set!)
(%byte-string-set! #x61 byte-string-set!) (#%byte-string-set! #x61 byte-string-set!)
(%struct-set! #x62 struct-set!))) (#%struct-set! #x62 struct-set!)))
(define value-primitives (define value-primitives
(append unary-value-primitives (append unary-value-primitives
binary-value-primitives binary-value-primitives
(list '(%if #f #f)))) (list '(#%if #f #f))))
(define statement-primitives (define statement-primitives
(append unary-statement-primitives (append unary-statement-primitives
@ -153,18 +156,18 @@
(define global-variables (define global-variables
(for/list ([i (in-range 1 64)]) (for/list ([i (in-range 1 64)])
(string->uninterned-symbol (string-append "%g" (number->string i))))) (string->uninterned-symbol (string-append "#%g" (number->string i)))))
(define instance-variables (define instance-variables
(for/list ([i (in-range 0 64)]) (for/list ([i (in-range 0 64)])
(string->uninterned-symbol (string-append "%i" (number->string i))))) (string->uninterned-symbol (string-append "#%i" (number->string i)))))
(define frame-variables (define frame-variables
(for/list ([i (in-range 0 120)]) (for/list ([i (in-range 0 120)])
(string->uninterned-symbol (string-append "%f" (number->string i))))) (string->uninterned-symbol (string-append "#%f" (number->string i)))))
(define special-variables (define special-variables
'(%nil %self %argv %ctx %k)) '(#%nil #%self #%argv #%ctx #%k))
(define (global-variable? var) (and (memq var global-variables) #t)) (define (global-variable? var) (and (memq var global-variables) #t))
(define (instance-variable? var) (and (memq var instance-variables) #t)) (define (instance-variable? var) (and (memq var instance-variables) #t))

21
libcompiler/reader.scm
View File

@ -9,26 +9,7 @@
(define (read-module [port (current-input-port)]) (define (read-module [port (current-input-port)])
`(lambda *argv* `(lambda *argv*
,@(let iter ([forms (read-forms port)] ,@(read-forms port)))
[bindings '()])
(match forms
['()
(if (null? bindings)
'()
`((letrec ,(reverse bindings))))]
[`((define (,(? symbol? var) . ,arglist) . ,body) . ,rst)
(iter rst (cons (list var `(lambda ,arglist ,@body)) bindings))]
[`((define ,(? symbol? var) ,expr) . ,rst)
(iter rst (cons (list var expr) bindings))]
[`((define . ,_) . ,_)
(error "Unrecognized define-form:" (first forms))]
[`((begin . ,body) . ,rst)
(iter (append body rst) bindings)]
[`(,form . ,rst)
(if (null? bindings)
(cons form (iter rst '()))
`((letrec ,(reverse bindings)
,@(cons form (iter rst '())))))]))))
(define (read-forms [port (current-input-port)]) (define (read-forms [port (current-input-port)])
(let iter ([form (read port)] (let iter ([form (read port)]

298
libcompiler/simplifier.scm
View File

@ -10,42 +10,72 @@
(define (simplify-form form) (define (simplify-form form)
(define (same-form recurse . form) form) (define (same-form recurse . form) form)
(define (reverse-args new-op args)
(simplify-form
(let ([a (gensym)] [b (gensym)])
`(let ([,a ,(first args)]
[,b ,(second args)])
(,new-op ,b ,a)))))
(define (simplify-complex-form recurse op . others) (define (simplify-complex-form recurse op . others)
(case op (case op
[(let) (simplify-let form)] [(let) (simplify-let form)]
[(let*) (simplify-let* form)] [(let*) (simplify-let* form)]
[(letrec) (simplify-letrec form)] [(letrec) (simplify-letrec form)]
[(if) (simplify-if form)] [(if) (simplify-if form)]
[(lambda) (simplify-lambda form)] [(lambda) (simplify-lambda form)]
[(begin) (simplify-form `(let () ,@(cdr form)))] [(begin) (simplify-form `(let () ,@(cdr form)))]
[(set!) (simplify-set! form)] [(set!) (simplify-set! form)]
[(let/cc) (simplify-form [(let/cc) (simplify-form
`(call/cc (lambda (,(second form)) ,@(cddr form))))] `(call/cc (lambda (,(second form)) ,@(cddr form))))]
[(fix>) (simplify-form [(fix=) (simplify-form `(eq? ,@(cdr form)))]
(let ([a (gensym)] [b (gensym)]) [(fix>) (reverse-args 'fix< (cdr form))]
`(let ([,a ,(second form)] [(fix<=) (reverse-args 'fix>= (cdr form))]
[,b ,(third form)]) [(float>) (reverse-args 'float< (cdr form))]
(fix< ,b ,a))))] [(float<=) (reverse-args 'float>= (cdr form))]
[(fix<=) (simplify-form [(byte-string>) (reverse-args 'byte-string< (cdr form))]
(let ([a (gensym)] [b (gensym)]) [(byte-string<=) (reverse-args 'byte-string>= (cdr form))]
`(let ([,a ,(second form)] [(value-list) (simplify-value-list form)]
[,b ,(third form)]) [(values) (simplify-primitive '#%values (cdr form))]
(fix>= ,b ,a))))] [(list) (simplify-form `(value-list (values ,@(cdr form))))]
[(value-list) (simplify-value-list form)] [(apply) (simplify-apply (second form) (cddr form))]
[(values) (simplify-primitive '%values (cdr form))] [(call/cc) (simplify-primitive '#%call/cc (cdr form))]
[(apply) (simplify-apply (second form) (cddr form))]
[(call/cc) (simplify-primitive '%call/cc (cdr form))]
[(call-with-values) [(call-with-values)
(simplify-form (simplify-form
`(apply ,(third form) `(apply ,(third form)
(value-list (,(second form)))))] (value-list (,(second form)))))]
[(and)
(simplify-form
(cond
[(null? (cdr form)) '#t]
[(null? (cddr form)) (second form)]
[else (let ([x (gensym)])
`(let ([,x ,(second form)])
(if ,x (and ,@(cddr form)) ,x)))]))]
[(or)
(simplify-form
(cond
[(null? (cdr form)) '#f]
[(null? (cddr form)) (second form)]
[else (let ([x (gensym)])
`(let ([,x ,(second form)])
(if ,x ,x (or ,@(cddr form)))))]))]
[(cond)
(simplify-form
(match (cdr form)
[`() '(values)]
[`([else . ,forms] . ,_) `(begin ,@forms)]
[`([,cond-expr . ,forms] . ,rst) `(if ,cond-expr (begin ,@forms) (cond ,@rst))]
[_ (error "Malformed (cond) form.")]))]
[(when) (simplify-form `(if ,(second form) (begin ,@(cddr form)) (values)))]
[(unless) (simplify-form `(if ,(second form) (values) (begin ,@(cddr form))))]
[else [else
(let ([primitive (memf (lambda (x) (eq? (third x) (first form))) (let ([primitive (memf (lambda (x) (eq? (third x) (first form)))
all-primitives)]) all-primitives)])
(if primitive (if primitive
(simplify-primitive (first (first primitive)) (simplify-primitive (first (first primitive))
(cdr form)) (cdr form))
(simplify-apply (first form) (append (cdr form) '(%nil)))))])) (simplify-apply (first form) (append (cdr form) '(#%nil)))))]))
(map-form form (map-form form
#:bind same-form #:bind same-form
#:lambda same-form #:lambda same-form
@ -54,61 +84,81 @@
#:primitive same-form #:primitive same-form
#:simple (lambda (recurse kind form) form) #:simple (lambda (recurse kind form) form)
#:literal (lambda (recurse kind form) #:literal (lambda (recurse kind form)
(if (equal? form '(quote ())) '%nil form)) (if (equal? form '(quote ())) '#%nil form))
#:other simplify-complex-form)) #:other simplify-complex-form))
(define (body->forms body)
(let iter ([body body]
[bindings '()])
(match body
['()
(if (null? bindings)
'()
`((letrec ,(reverse bindings))))]
[`((define (,(? symbol? var) . ,arglist) . ,body) . ,rst)
(iter rst (cons (list var `(lambda ,arglist ,@body)) bindings))]
[`((define ,(? symbol? var) ,expr) . ,rst)
(iter rst (cons (list var expr) bindings))]
[`((define . ,_) . ,_)
(error "Unrecognized define-form:" (first body))]
[`(,form . ,rst)
(if (null? bindings)
(cons form (iter rst '()))
`((letrec ,(reverse bindings)
,@(cons form (iter rst '())))))])))
(define (simplify-set! form) (define (simplify-set! form)
(let ([variable (second form)] (let ([variable (second form)]
[value-form (simplify-form (third form))]) [value-form (simplify-form (third form))])
(match value-form (match value-form
[`(%bind ,bound-vars . ,subforms) [`(#%bind ,bound-vars . ,subforms)
(if (memq variable bound-vars) (if (memq variable bound-vars)
(let ([tmp (gensym)]) (let ([tmp (gensym)])
`(%bind (,tmp) `(#%bind (,tmp)
; guaranteed not to cause unbounded recursion: tmp is unique ; guaranteed not to cause unbounded recursion: tmp is unique
,(simplify-set! `(set! ,tmp ,value-form)) ,(simplify-set! `(set! ,tmp ,value-form))
(%set! ,variable ,tmp))) (#%set! ,variable ,tmp)))
`(%bind ,bound-vars `(#%bind ,bound-vars
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
(if (pair? after) (if (pair? after)
(cons subform after) (cons subform after)
(list (simplify-set! `(set! ,variable ,subform))))) (list (simplify-set! `(set! ,variable ,subform)))))
'() '()
subforms)))] subforms)))]
[`(%values ,first-val . ,other-vals) [`(#%values ,first-val . ,other-vals)
`(%set! ,variable ,first-val)] `(#%set! ,variable ,first-val)]
[`(%values) [`(#%values)
(error "Attempted to set variable to void in:" form)] (error "Attempted to set variable to void in:" form)]
[(? value-form?) [(? value-form?)
`(%set! ,variable ,value-form)] `(#%set! ,variable ,value-form)]
[else [else
(error "Attempted to set variable to void in:" form)]))) (error "Attempted to set variable to void in:" form)])))
(define (simplify-value-list form) (define (simplify-value-list form)
(let ([values-form (simplify-form (second form))]) (let ([values-form (simplify-form (second form))])
(match values-form (match values-form
[`(%bind ,bound-vars . ,subforms) [`(#%bind ,bound-vars . ,subforms)
`(%bind ,bound-vars `(#%bind ,bound-vars
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
(if (pair? after) (if (pair? after)
(cons subform after) (cons subform after)
(list (simplify-value-list `(value-list ,subform))))) (list (simplify-value-list `(value-list ,subform)))))
'() '()
subforms))] subforms))]
[`(%values . ,simple-vals) [`(#%values . ,simple-vals)
; (%value-list (%values ...)) => (list ...) ; (#%value-list (#%values ...)) => (list ...)
(let ([tmp (gensym)]) (let ([tmp (gensym)])
`(%bind (,tmp) `(#%bind (,tmp)
(%set! ,tmp %nil) (#%set! ,tmp #%nil)
,@(map (lambda (x) (simplify-set! `(set! ,tmp (cons ,x ,tmp)))) ,@(map (lambda (x) (simplify-set! `(set! ,tmp (cons ,x ,tmp))))
(reverse simple-vals)) (reverse simple-vals))
,tmp))] ,tmp))]
[(or `(%apply _ _) [(or `(#%apply _ _)
`(%call/cc _)) `(#%call/cc _))
`(%value-list ,values-form)] `(#%value-list ,values-form)]
[(? value-form?) [(? value-form?)
(simplify-value-list `(value-list (values ,values-form)))] (simplify-value-list `(value-list (values ,values-form)))]
[_ '%nil]))) [_ '#%nil])))
(define (simplify-primitive simple-op value-forms) (define (simplify-primitive simple-op value-forms)
(define (value->binding value-form) (define (value->binding value-form)
@ -126,10 +176,10 @@
(,simple-op ,@(map first bindings))))) (,simple-op ,@(map first bindings)))))
; (let ([var expr]...) bodyexpr...) ; first eval exprs, then assign bindings in parallel ; (let ([var expr]...) bodyexpr...) ; first eval exprs, then assign bindings in parallel
; => (%bind (tmp...) ; => (#%bind (tmp...)
; (%set! tmp ,(simplify-form expr))... ; (#%set! tmp ,(simplify-form expr))...
; (%bind (var...) ; (#%bind (var...)
; (%set! var tmp)... ; (#%set! var tmp)...
; bodyexpr...)) ; bodyexpr...))
(define (simplify-let form) (define (simplify-let form)
@ -138,28 +188,28 @@
(list (first binding) (simplify-form (second binding))) (list (first binding) (simplify-form (second binding)))
(list binding))) (list binding)))
(define bindings (map simplify-binding (second form))) (define bindings (map simplify-binding (second form)))
(define bodyexprs (cddr form)) (define bodyexprs (body->forms (cddr form)))
(define (has-value? binding) (pair? (cdr binding))) (define (has-value? binding) (pair? (cdr binding)))
(define vars (map first bindings)) (define vars (map first bindings))
(define (bound-var? var) (and (memq var vars) #t)) (define (bound-var? var) (and (memq var vars) #t))
; If the value of any binding refers to one of the variable names being bound... ; If the value of any binding refers to one of the variable names being bound...
(if (ormap bound-var? (free-variables `(%bind () ,@(map second (filter has-value? bindings))))) (if (ormap bound-var? (free-variables `(#%bind () ,@(map second (filter has-value? bindings)))))
; ...then bind the values to temps first, before binding the real names. ; ...then bind the values to temps first, before binding the real names.
(let ([temp-bindings (map (lambda (binding) (let ([temp-bindings (map (lambda (binding)
(let ([tmp (gensym)]) (let ([tmp (gensym)])
(list tmp (list tmp
(simplify-set! `(set! ,tmp ,(second binding))) (simplify-set! `(set! ,tmp ,(second binding)))
`(%set! ,(first binding) ,tmp)))) `(#%set! ,(first binding) ,tmp))))
(filter has-value? bindings))]) (filter has-value? bindings))])
`(%bind ,(map first temp-bindings) `(#%bind ,(map first temp-bindings)
,@(map second temp-bindings) ,@(map second temp-bindings)
(%bind ,vars (#%bind ,vars
,@(map third temp-bindings) ,@(map third temp-bindings)
,@(map simplify-form bodyexprs)))) ,@(map simplify-form bodyexprs))))
; Otherwise, just bind the real names directly. ; Otherwise, just bind the real names directly.
`(%bind ,vars `(#%bind ,vars
,@(map (lambda (binding) ,@(map (lambda (binding)
(simplify-set! `(set! ,@binding))) (simplify-set! `(set! ,@binding)))
(filter has-value? bindings)) (filter has-value? bindings))
@ -206,15 +256,15 @@
(if (and (simple-value? true-form) (if (and (simple-value? true-form)
(simple-value? false-form)) (simple-value? false-form))
`(let ([,cond-val ,cond-expr]) `(let ([,cond-val ,cond-expr])
(%if ,cond-val ,true-form ,false-form)) (#%if ,cond-val ,true-form ,false-form))
(let ([next-fn (gensym)] (let ([next-fn (gensym)]
[true-fn (gensym)] [true-fn (gensym)]
[false-fn (gensym)]) [false-fn (gensym)])
`(let ([,cond-val ,cond-expr] `(let ([,cond-val ,cond-expr]
[,true-fn (lambda () ,true-form)] [,true-fn (lambda () ,true-form)]
[,false-fn (lambda () ,false-form)]) [,false-fn (lambda () ,false-form)])
(let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)]) (let ([,next-fn (#%if ,cond-val ,true-fn ,false-fn)])
(%apply ,next-fn %nil)))))))) (#%apply ,next-fn #%nil))))))))
; (lambda (required... [optional default-expr]... . rest) bodyexpr...) ; (lambda (required... [optional default-expr]... . rest) bodyexpr...)
; => (lambda argv ; => (lambda argv
@ -225,12 +275,12 @@
; (set! argv-temp (cdr argv-temp))) ; (set! argv-temp (cdr argv-temp)))
; (... ; (...
; (let (optional-0) ; (let (optional-0)
; (if (eq? argv-temp %nil) ; (if (eq? argv-temp #%nil)
; (set! optional-0 default-expr-0) ; (set! optional-0 default-expr-0)
; (set! optional-0 (car argv-temp))) ; (set! optional-0 (car argv-temp)))
; (set! argv-temp (cdr argv-temp)) ; (set! argv-temp (cdr argv-temp))
; (let (optional-1) ; (let (optional-1)
; (if (eq? argv-temp %nil) ; (if (eq? argv-temp #%nil)
; (set! optional-1 default-expr-1) ; (set! optional-1 default-expr-1)
; (set! optional-1 (car argv-temp))) ; (set! optional-1 (car argv-temp)))
; ; TODO: Handle keyword arguments here... ; ; TODO: Handle keyword arguments here...
@ -243,20 +293,20 @@
(map-form form (map-form form
#:bind (lambda (recurse op vars . subforms) #:bind (lambda (recurse op vars . subforms)
(flatten-binds (flatten-binds
`(%bind ,(subst variable variable vars) `(#%bind ,(subst variable variable vars)
,@(if (memq variable vars) ,@(if (memq variable vars)
`((%set! ,variable (%make-box %undef))) `((#%set! ,variable (#%make-box #%undef)))
'()) '())
,@(map recurse subforms)))) ,@(map recurse subforms))))
#:set (lambda (recurse op var value) #:set (lambda (recurse op var value)
(let ([new-value (recurse value)]) (let ([new-value (recurse value)])
(if (eq? var variable) (if (eq? var variable)
(if (simple-value? new-value) (if (simple-value? new-value)
`(%set-box! ,variable ,new-value) `(#%set-box! ,variable ,new-value)
(let ([tmp (gensym)]) (let ([tmp (gensym)])
`(%bind (,tmp) `(#%bind (,tmp)
,(simplify-set! `(set! ,tmp ,new-value)) ,(simplify-set! `(set! ,tmp ,new-value))
(%set-box! ,variable ,tmp)))) (#%set-box! ,variable ,tmp))))
(simplify-set! `(set! ,var ,new-value))))) (simplify-set! `(set! ,var ,new-value)))))
#:value-list (lambda (recurse op values-form) #:value-list (lambda (recurse op values-form)
`(,op ,(recurse values-form))) `(,op ,(recurse values-form)))
@ -267,15 +317,15 @@
(if (simple-value? x) (if (simple-value? x)
(list x #f) (list x #f)
(let ([tmp (gensym)]) (let ([tmp (gensym)])
(list tmp `(%set! ,tmp ,x))))) (list tmp `(#%set! ,tmp ,x)))))
new-args)]) new-args)])
(if (ormap second temps) (if (ormap second temps)
`(%bind ,(map first (filter second temps)) `(#%bind ,(map first (filter second temps))
,@(filter-map second temps) ,@(filter-map second temps)
(,op ,@(map first temps))) (,op ,@(map first temps)))
`(,op ,@new-args))))) `(,op ,@new-args)))))
#:variable (lambda (recurse op var) #:variable (lambda (recurse op var)
(if (eq? var variable) `(%unbox ,variable) var)))) (if (eq? var variable) `(#%unbox ,variable) var))))
(define (is-shared-var? var forms) (define (is-shared-var? var forms)
(define (set-after-first-capture?) (define (set-after-first-capture?)
@ -327,19 +377,19 @@
(second flat-bind)))) (second flat-bind))))
(promote-shared-variables (promote-shared-variables
`(%bind ,(remove* extra-bindings (second flat-bind)) `(#%bind ,(remove* extra-bindings (second flat-bind))
,@(map (lambda (subform) ,@(map (lambda (subform)
(match subform (match subform
[`(%set! ,var (%lambda ,g-vars ,i-vars ,bind)) [`(#%set! ,var (#%lambda ,g-vars ,i-vars ,bind))
(define (free-var? v) (free-variable? v bind)) (define (free-var? v) (free-variable? v bind))
(define local-binds (filter free-var? extra-bindings)) (define local-binds (filter free-var? extra-bindings))
(if (null? local-binds) (if (null? local-binds)
subform subform
(begin (begin
(set! extra-bindings (remove* local-binds extra-bindings)) (set! extra-bindings (remove* local-binds extra-bindings))
`(%set! ,var (%lambda ,g-vars ,i-vars `(#%set! ,var (#%lambda ,g-vars ,i-vars
,(narrow-binds+promote ,(narrow-binds+promote
`(%bind (,@(second bind) ,@local-binds) `(#%bind (,@(second bind) ,@local-binds)
,@(cddr bind)))))))] ,@(cddr bind)))))))]
[_ subform])) [_ subform]))
(cddr flat-bind))))) (cddr flat-bind)))))
@ -355,33 +405,33 @@
(define (add-return ctx k nested-bind) (define (add-return ctx k nested-bind)
(define flat-bind (flatten-binds nested-bind)) (define flat-bind (flatten-binds nested-bind))
(define argv (gensym)) (define argv (gensym))
`(%bind (,@(second flat-bind) ,argv) `(#%bind (,@(second flat-bind) ,argv)
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
(if (pair? after) (if (pair? after)
(cons subform after) (cons subform after)
(match subform (match subform
[(? simple-value?) [(? simple-value?)
`((%set! ,argv (%cons ,subform %nil)) `((#%set! ,argv (#%cons ,subform #%nil))
(%tail-call ,k ,argv #f #f))] (#%tail-call ,k ,argv #f #f))]
[`(%apply ,x ,y) [`(#%apply ,x ,y)
`((%tail-call ,x ,y ,ctx ,k))] `((#%tail-call ,x ,y ,ctx ,k))]
[`(%call/cc ,x) [`(#%call/cc ,x)
`((%set! ,argv (%cons %k %nil)) `((#%set! ,argv (#%cons #%k #%nil))
(%tail-call ,x ,argv ,ctx %k))] (#%tail-call ,x ,argv ,ctx #%k))]
[`(%values . ,simple-vals) [`(#%values . ,simple-vals)
`((%set! ,argv %nil) `((#%set! ,argv #%nil)
,@(map (lambda (sv) `(%set! ,argv (%cons ,sv ,argv))) ,@(map (lambda (sv) `(#%set! ,argv (#%cons ,sv ,argv)))
(reverse simple-vals)) (reverse simple-vals))
(%tail-call ,k ,argv #f #f))] (#%tail-call ,k ,argv #f #f))]
[(? value-form?) [(? value-form?)
`(,(simplify-set! `(set! ,argv ,subform)) `(,(simplify-set! `(set! ,argv ,subform))
(%set! ,argv (%cons ,argv %nil)) (#%set! ,argv (#%cons ,argv #%nil))
(%tail-call ,k ,argv #f #f))] (#%tail-call ,k ,argv #f #f))]
[`(%tail-call . ,_) [`(#%tail-call . ,_)
`(,subform)] `(,subform)]
[_ [_
`(,subform `(,subform
(%tail-call ,k %nil #f #f))]))) (#%tail-call ,k #%nil #f #f))])))
'() '()
(cddr flat-bind)))) (cddr flat-bind))))
@ -389,61 +439,61 @@
(define flat-bind (flatten-binds nested-bind)) (define flat-bind (flatten-binds nested-bind))
(define (cps-prepend subform after) (define (cps-prepend subform after)
(match subform (match subform
[`(%set! ,v (%value-list (%apply ,x ,y))) [`(#%set! ,v (#%value-list (#%apply ,x ,y)))
(let ([k (gensym)]) (let ([k (gensym)])
`((%bind (,k) `((#%bind (,k)
(%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda ,v `(lambda ,v
,@after))) ,@after)))
(%tail-call ,x ,y ,ctx ,k))))] (#%tail-call ,x ,y ,ctx ,k))))]
[`(%set! ,v (%apply ,x ,y)) [`(#%set! ,v (#%apply ,x ,y))
(let ([k (gensym)]) (let ([k (gensym)])
`((%bind (,k) `((#%bind (,k)
(%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda (,v . ,(gensym)) `(lambda (,v . ,(gensym))
,@after))) ,@after)))
(%tail-call ,x ,y ,ctx ,k))))] (#%tail-call ,x ,y ,ctx ,k))))]
[(or `(%value-list (%apply ,x ,y)) [(or `(#%value-list (#%apply ,x ,y))
`(%apply ,x ,y)) `(#%apply ,x ,y))
(let ([k (gensym)]) (let ([k (gensym)])
`((%bind (,k) `((#%bind (,k)
(%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda ,(gensym) `(lambda ,(gensym)
,@after))) ,@after)))
(%tail-call ,x ,y ,ctx ,k))))] (#%tail-call ,x ,y ,ctx ,k))))]
[`(%set! ,v (%value-list (%call/cc ,x))) [`(#%set! ,v (#%value-list (#%call/cc ,x)))
(let ([k (gensym)] (let ([k (gensym)]
[k-argv (gensym)]) [k-argv (gensym)])
`((%bind (,k ,k-argv) `((#%bind (,k ,k-argv)
(%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda ,v `(lambda ,v
,@after))) ,@after)))
(%set! ,k-argv (%cons ,k %nil)) (#%set! ,k-argv (#%cons ,k #%nil))
(%tail-call ,x ,k-argv ,ctx ,k))))] (#%tail-call ,x ,k-argv ,ctx ,k))))]
[`(%set! ,v (%call/cc ,x)) [`(#%set! ,v (#%call/cc ,x))
(let ([k (gensym)] (let ([k (gensym)]
[k-argv (gensym)]) [k-argv (gensym)])
`((%bind (,k ,k-argv) `((#%bind (,k ,k-argv)
(%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda (,v . ,(gensym)) `(lambda (,v . ,(gensym))
,@after))) ,@after)))
(%set! ,k-argv (%cons ,k %nil)) (#%set! ,k-argv (#%cons ,k #%nil))
(%tail-call ,x ,k-argv ,ctx ,k))))] (#%tail-call ,x ,k-argv ,ctx ,k))))]
[(or `(%value-list (%call/cc ,x)) [(or `(#%value-list (#%call/cc ,x))
`(%call/cc ,x)) `(#%call/cc ,x))
(let ([k (gensym)] (let ([k (gensym)]
[k-argv (gensym)]) [k-argv (gensym)])
`((%bind (,k ,k-argv) `((#%bind (,k ,k-argv)
(%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda ,(gensym) `(lambda ,(gensym)
,@after))) ,@after)))
(%set! ,k-argv (%cons ,k %nil)) (#%set! ,k-argv (#%cons ,k #%nil))
(%tail-call ,x ,k-argv ,ctx ,k))))] (#%tail-call ,x ,k-argv ,ctx ,k))))]
; keep all other forms with side-effects as-is ; keep all other forms with side-effects as-is
[(? statement-form?) (cons subform after)] [(? statement-form?) (cons subform after)]
; discard any form without side-effects ; discard any form without side-effects
[_ after])) [_ after]))
`(%bind ,(second flat-bind) `(#%bind ,(second flat-bind)
,@(foldr cps-prepend '() (cddr flat-bind)))) ,@(foldr cps-prepend '() (cddr flat-bind))))
(define (simplify-lambda form) (define (simplify-lambda form)
@ -475,14 +525,14 @@
`(let ([,rest ,argv]) ,@bodyexprs) `(let ([,rest ,argv]) ,@bodyexprs)
`(begin ,@bodyexprs))) `(begin ,@bodyexprs)))
`(%lambda () () `(#%lambda () ()
,((compose narrow-binds+promote ,((compose narrow-binds+promote
(lambda (bind) (transform-to-cps ctx bind)) (lambda (bind) (transform-to-cps ctx bind))
(lambda (bind) (add-return ctx k bind)) (lambda (bind) (add-return ctx k bind))
simplify-form) simplify-form)
`(let ([,argv %argv] `(let ([,argv #%argv]
[,ctx %ctx] [,ctx #%ctx]
[,k %k]) [,k #%k])
,(foldr add-req ,(foldr add-req
(foldr add-opt (foldr add-opt
rest+bodyexprs rest+bodyexprs
@ -493,9 +543,9 @@
; => (let ([fn-var fn-expr] arg-var... argv) ; => (let ([fn-var fn-expr] arg-var... argv)
; (set! fn-var fn-expr) ; (set! fn-var fn-expr)
; (set! arg-var arg-expr)... ; (set! arg-var arg-expr)...
; (set! argv %nil) ; (set! argv #%nil)
; (set! argv (cons arg-var argv))... [reversed] ; (set! argv (cons arg-var argv))... [reversed]
; (%apply fn-var argv)) ; (#%apply fn-var argv))
(define (simplify-apply fn-expr arg-exprs) (define (simplify-apply fn-expr arg-exprs)
(define fn-var (gensym)) (define fn-var (gensym))
@ -511,8 +561,8 @@
arg-exprs)) arg-exprs))
(simplify-form (simplify-form
`(let ([,fn-var ,fn-expr] ,@(filter second arguments)) `(let ([,fn-var ,fn-expr] ,@(filter second arguments))
,@(map (lambda (x) `(%set! ,argv (%cons ,x ,argv))) ,@(map (lambda (x) `(#%set! ,argv (#%cons ,x ,argv)))
(map first (reverse (drop-right arguments 1)))) (map first (reverse (drop-right arguments 1))))
(%apply ,fn-var ,argv)))) (#%apply ,fn-var ,argv))))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab:

42
libcompiler/utilities.scm
View File

@ -101,13 +101,13 @@
(define (variable-value? form) (define (variable-value? form)
(and (symbol? form) (and (symbol? form)
(not (eq? form '%undef)))) (not (eq? form '#%undef))))
(define (literal-value? form) (define (literal-value? form)
(and (not (variable-value? form)) (and (not (variable-value? form))
(or (not (pair? form)) (or (not (pair? form))
(eq? (first form) 'quote) (eq? (first form) 'quote)
(eq? (first form) '%template)))) (eq? (first form) '#%template))))
(define (simple-value? form) (define (simple-value? form)
(or (variable-value? form) (or (variable-value? form)
@ -116,14 +116,14 @@
; A value-form is any simple form which can appear on the right-hand side of a (set! ...). ; A value-form is any simple form which can appear on the right-hand side of a (set! ...).
; If there are any side-effect they occur before the variable is updated. ; If there are any side-effect they occur before the variable is updated.
(define (value-form? form) (define (value-form? form)
(define complex-values '(%bind %lambda %apply %call/cc %values %value-list)) (define complex-values '(#%bind #%lambda #%apply #%call/cc #%values #%value-list))
(or (simple-value? form) (or (simple-value? form)
(memq (first form) complex-values) (memq (first form) complex-values)
(memq (first form) (map first 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) (map first statement-primitives))))) (memq (first form) (map first statement-primitives)))))
@ -137,7 +137,7 @@
(not (statement-form? form)))) (not (statement-form? form))))
(define (bind-form? form) (define (bind-form? form)
(and (pair? form) (eq? (first form) '%bind))) (and (pair? form) (eq? (first form) '#%bind)))
(define (traverse-form form (define (traverse-form form
#:bind [bind-fn (lambda (recurse op vars . subforms) #:bind [bind-fn (lambda (recurse op vars . subforms)
@ -168,14 +168,14 @@
[(literal-value? subform) (literal-fn recurse 'literal subform)] [(literal-value? subform) (literal-fn recurse 'literal subform)]
[else [else
(let ([handler (case (first subform) (let ([handler (case (first subform)
[(%bind) bind-fn] [(#%bind) bind-fn]
[(%lambda) lambda-fn] [(#%lambda) lambda-fn]
[(%set!) set-fn] [(#%set!) set-fn]
[(%value-list) value-list-fn] [(#%value-list) value-list-fn]
[(%values) values-fn] [(#%values) values-fn]
[(%apply) apply-fn] [(#%apply) apply-fn]
[(%call/cc) call/cc-fn] [(#%call/cc) call/cc-fn]
[(%tail-call) tail-call-fn] [(#%tail-call) tail-call-fn]
[else (if (primitive-form? subform) [else (if (primitive-form? subform)
primitive-fn primitive-fn
other-fn)])]) other-fn)])])
@ -261,7 +261,9 @@
(define (subst-var old-var new-var form) (define (subst-var old-var new-var form)
(map-form form (map-form form
#:bind (lambda (recurse op vars . subforms) #:bind (lambda (recurse op vars . subforms)
`(%bind ,(subst old-var new-var vars) ,@(map recurse subforms))) (if (memq old-var vars)
`(,op ,vars ,@subforms)
`(#%bind ,vars ,@(map recurse subforms))))
#:set (lambda (recurse op var value) #:set (lambda (recurse op var value)
`(,op ,(if (eq? var old-var) new-var var) ,(recurse value))) `(,op ,(if (eq? var old-var) new-var var) ,(recurse value)))
#:variable (lambda (recurse op var) #:variable (lambda (recurse op var)
@ -270,7 +272,12 @@
(define (subst-var* var-map form) (define (subst-var* var-map form)
(map-form form (map-form form
#:bind (lambda (recurse op vars . subforms) #:bind (lambda (recurse op vars . subforms)
`(%bind ,(subst* var-map vars) ,@(map recurse subforms))) (let ([unbound-map (filter (lambda (item) (not (memq (car item) vars)))
var-map)])
(if (null? unbound-map)
`(,op ,vars ,@subforms)
`(#%bind ,vars ,@(map (lambda (sf) (subst-var* unbound-map sf))
subforms)))))
#:set (lambda (recurse op var value) #:set (lambda (recurse op var value)
(let ([item (assoc var var-map)]) (let ([item (assoc var var-map)])
`(,op ,(if item (second item) var) ,(recurse value)))) `(,op ,(if item (second item) var) ,(recurse value))))
@ -284,7 +291,8 @@
(define (make-binding-unique var bind) (define (make-binding-unique var bind)
(let* ([prefix (string-append (symbol->string var) "->g")] (let* ([prefix (string-append (symbol->string var) "->g")]
[unique-var (gensym prefix)]) [unique-var (gensym prefix)])
(subst-var var unique-var bind))) `(#%bind ,(subst var unique-var (second bind))
,@(map (lambda (sf) (subst-var var unique-var sf))))))
(foldr make-binding-unique bind (filter needs-rename? (second bind)))) (foldr make-binding-unique bind (filter needs-rename? (second bind))))
(map-form form (map-form form
@ -302,7 +310,7 @@
(cddr unique-form)) (cddr unique-form))
(list subform))) (list subform)))
(let ([subforms (append-map form->list original-subforms)]) (let ([subforms (append-map form->list original-subforms)])
`(%bind ,bound-vars ,@subforms))) `(#%bind ,bound-vars ,@subforms)))
#:lambda (lambda (recurse . form) form))) #:lambda (lambda (recurse . form) form)))
(define (free-variables form [input? #t] [output? #t]) (define (free-variables form [input? #t] [output? #t])

22
libcompiler/writer.scm
View File

@ -55,14 +55,14 @@
(let-values ([(line col pos) (port-next-location port)]) (let-values ([(line col pos) (port-next-location port)])
(parameterize ([current-indent col]) (parameterize ([current-indent col])
(write-char #\" port) (write-char #\" port)
(if (eq? (first (first forms)) '%tail-call) (if (eq? (first (first forms)) '#%tail-call)
(begin (begin
(write-char #\" port) (write-char #\" port)
(write-tail-call (first forms))) (write-tail-call (first forms)))
(let iter ([forms forms]) (let iter ([forms forms])
(map (lambda (x) (write-hex-char x port)) (map (lambda (x) (write-hex-char x port))
(statement->code (car forms))) (statement->code (car forms)))
(if (eq? (first (second forms)) '%tail-call) (if (eq? (first (second forms)) '#%tail-call)
(begin (begin
(write-string "\"; " port) (write-string "\"; " port)
(write (car forms) port) (write (car forms) port)
@ -75,11 +75,11 @@
(iter (cdr forms))))))))) (iter (cdr forms)))))))))
(define (write-rla-function value port) (define (write-rla-function value port)
(define template? (eq? (first value) '%template)) (define template? (eq? (first value) '#%template))
(let-values ([(line col pos) (port-next-location port)]) (let-values ([(line col pos) (port-next-location port)])
(parameterize ([current-indent col]) (parameterize ([current-indent col])
(write-string "#S(" port) (write-string "#S(" port)
(if (eq? (first value) '%template) (if (eq? (first value) '#%template)
(write-string "#=\"template\"" port) (write-string "#=\"template\"" port)
(write-string "#=\"lambda\"" port)) (write-string "#=\"lambda\"" port))
(parameterize ([current-indent (+ (current-indent-step) (current-indent))]) (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
@ -115,7 +115,7 @@
(port-count-lines! port) (port-count-lines! port)
(void (void
(cond (cond
[(eq? value '%undef) [(eq? value '#%undef)
(write-string "#=\"undefined\"" port)] (write-string "#=\"undefined\"" port)]
[(symbol? value) [(symbol? value)
(write-string "#=\"" port) (write-string "#=\"" port)
@ -123,9 +123,11 @@
(write-string "\"" port)] (write-string "\"" port)]
[(or (boolean? value) (number? value)) [(or (boolean? value) (number? value))
(write value port)] (write value port)]
[(char? value)
(write (char->integer value) port)]
[(string? value) [(string? value)
(write-rla-string value port)] (write-rla-string value port)]
[(and (pair? value) (memq (first value) '(%lambda %template))) [(and (pair? value) (memq (first value) '(#%lambda #%template)))
(write-rla-function value port)] (write-rla-function value port)]
[(vector? value) [(vector? value)
(write-string "#(" port) (write-string "#(" port)
@ -154,19 +156,19 @@
[else (error "Don't know how to write Rosella syntax for:" value)]))) [else (error "Don't know how to write Rosella syntax for:" value)])))
(define (variable->code var) (define (variable->code var)
(or (and (eq? var '%nil) #x00) (or (and (eq? var '#%nil) #x00)
(let ([index (find var global-variables)]) (let ([index (find var global-variables)])
(and index (+ #x01 index))) (and index (+ #x01 index)))
(let ([index (find var instance-variables)]) (let ([index (find var instance-variables)])
(and index (+ #x40 index))) (and index (+ #x40 index)))
(let ([index (find var frame-variables)]) (let ([index (find var frame-variables)])
(and index (+ #x80 index))) (and index (+ #x80 index)))
(let ([index (find var '(%self %argv %ctx %k))]) (let ([index (find var '(#%self #%argv #%ctx #%k))])
(and index (+ #xfc index))) (and index (+ #xfc index)))
(error "No bytecode for variable:" var))) (error "No bytecode for variable:" var)))
(define (statement->code form) (define (statement->code form)
(if (eq? (first form) '%set!) (if (eq? (first form) '#%set!)
(let ([out (variable->code (second form))] (let ([out (variable->code (second form))]
[value (third form)]) [value (third form)])
(cond (cond
@ -179,7 +181,7 @@
(list* (second (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)
(eq? (length (cdr value)) 3)) (eq? (length (cdr value)) 3))
(error "Unsupported ternary form:" form)) (error "Unsupported ternary form:" form))
(list* out (map variable->code (cdr value)))])) (list* out (map variable->code (cdr value)))]))

7
reader.c
View File

@ -712,8 +712,15 @@ static value_t read_placeholder(reader_state_t *state)
{ {
char *name = value_to_string(read_string(state)); char *name = value_to_string(read_string(state));
value_t bi = lookup_builtin(name); value_t bi = lookup_builtin(name);
if (bi == FALSE_VALUE)
{
fprintf(stderr, "Unable to locate \"%s\" builtin.\n", name);
}
free(name); free(name);
release_assert(bi != FALSE_VALUE); release_assert(bi != FALSE_VALUE);
return bi; return bi;
} }
else else

12
src/lib/primitives.rls
View File

@ -78,8 +78,11 @@
(define (fix* x y) (fix* x y)) (define (fix* x y) (fix* x y))
(define (fix/ x y) (fix/ x y)) (define (fix/ x y) (fix/ x y))
(define (fix% x y) (fix% x y)) (define (fix% x y) (fix% x y))
(define (fix= x y) (fix= x y))
(define (fix< x y) (fix< x y)) (define (fix< x y) (fix< x y))
(define (fix> x y) (fix> x y))
(define (fix>= x y) (fix>= x y)) (define (fix>= x y) (fix>= x y))
(define (fix<= x y) (fix<= x y))
(define (bit-and x y) (bit-and x y)) (define (bit-and x y) (bit-and x y))
(define (bit-or x y) (bit-or x y)) (define (bit-or x y) (bit-or x y))
(define (bit-xor x y) (bit-xor x y)) (define (bit-xor x y) (bit-xor x y))
@ -92,7 +95,9 @@
(define (float/ x y) (float/ x y)) (define (float/ x y) (float/ x y))
(define (float= x y) (float= x y)) (define (float= x y) (float= x y))
(define (float< x y) (float< x y)) (define (float< x y) (float< x y))
(define (float> x y) (float> x y))
(define (float>= x y) (float>= x y)) (define (float>= x y) (float>= x y))
(define (float<= x y) (float<= x y))
(define (atan2 x y) (atan2 x y)) (define (atan2 x y) (atan2 x y))
(define (pow x y) (pow x y)) (define (pow x y) (pow x y))
(define (ldexp x y) (ldexp x y)) (define (ldexp x y) (ldexp x y))
@ -104,6 +109,11 @@
(define (remainder x y) (remainder x y)) (define (remainder x y) (remainder x y))
(define (scalb x y) (scalb x y)) (define (scalb x y) (scalb x y))
(define (kind-of? x y) (kind-of? x y)) (define (kind-of? x y) (kind-of? x y))
(define (byte-string= x y) (byte-string= x y))
(define (byte-string< x y) (byte-string< x y))
(define (byte-string> x y) (byte-string> x y))
(define (byte-string>= x y) (byte-string>= x y))
(define (byte-string<= x y) (byte-string<= x y))
; Binary statement primitives ; Binary statement primitives
(define (set-box! x y) (set-box! x y)) (define (set-box! x y) (set-box! x y))
@ -115,4 +125,6 @@
(define (byte-string-set! x y z) (byte-string-set! x y z)) (define (byte-string-set! x y z) (byte-string-set! x y z))
(define (struct-set! x y z) (struct-set! x y z)) (define (struct-set! x y z) (struct-set! x y z))
(define (list . lst) lst)
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab: