Skip to content

Commit

Permalink
Update maru
Browse files Browse the repository at this point in the history
  • Loading branch information
@damelang
damelang committed Dec 25, 2012
1 parent 1d90627 commit 38cc894
Show file tree
Hide file tree
Showing 9 changed files with 271 additions and 114 deletions.
4 changes: 2 additions & 2 deletions compilers/maru/maru/.hg_archival.txt
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
repo: a03d05016b5b3dcab36a1c9fbcb2ce9ae8e9a2fa
node: edf061f28f3019a4212ec6cbe4b67c1f6de52b5e
node: c30fc4248a6cbf374a18f4e72ee52c445c9632d9
branch: default
latesttag: parse-ok
latesttagdistance: 511
latesttagdistance: 519
10 changes: 6 additions & 4 deletions compilers/maru/maru/Makefile
View file
Original file line number Diff line number Diff line change
Expand Up @@ -61,19 +61,21 @@ test3-maru : eval2
./eval2 ir-gen-x86.k maru.k maru-test3.k > test.s && cc -m32 -fno-builtin -g -o test3 test.s && ./test3

maru-check : eval2 .force
./eval2 ir-gen-x86.k maru.k maru-check.k > maru-check.s
./eval2 -g ir-gen-x86.k maru.k maru-check.k > maru-check.s
cc -m32 -o maru-check maru-check.s
./maru-check

maru-check-c : eval2 .force
./eval2 ir-gen-c.k maru.k maru-check.k > maru-check.c
cc -o maru-check maru-check.c
cc -o maru-check maru-check.c -ldl
./maru-check

maru-bench : eval2 .force
cc -O2 -fomit-frame-pointer -mdynamic-no-pic -o nfibs nfibs.c
## cc -O2 -fomit-frame-pointer -mdynamic-no-pic -o nfibs nfibs.c
cc -O2 -fomit-frame-pointer -o nfibs nfibs.c
./eval2 ir-gen-x86.k maru.k maru-nfibs.k > maru-nfibs.s
cc -O2 -fomit-frame-pointer -mdynamic-no-pic -o maru-nfibs maru-nfibs.s
## cc -O2 -fomit-frame-pointer -mdynamic-no-pic -o maru-nfibs maru-nfibs.s
cc -O2 -fomit-frame-pointer -o maru-nfibs maru-nfibs.s
time ./nfibs 38
time ./nfibs 38
time ./maru-nfibs 38
Expand Down
33 changes: 24 additions & 9 deletions compilers/maru/maru/boot2.l
View file
Original file line number Diff line number Diff line change
Expand Up @@ -665,7 +665,7 @@
;;(println "; backtrace disabled")
)

(define-function printf (fmt arg) (print (format fmt arg)))
;;(define-function printf (fmt arg) (print (format fmt arg)))

;;; multimethod

Expand Down Expand Up @@ -726,6 +726,17 @@
(set ,list (cdr _list_))
_head_))

(define-form delete (list element)
`(let ((_elt ,element))
(if (= _elt (car ,list))
(set ,list (cdr ,list))
(let ((_list ,list))
(while (cdr _list)
(if (!= _elt (cadr _list))
(set _list (cdr _list))
(set (cdr _list) (cddr _list))
(set _list ())))))))

(define-function member? (key list)
(while (and (pair? list) (!= key (car list)))
(set list (cdr list)))
Expand Down Expand Up @@ -1025,12 +1036,12 @@

;;; command line

(define *load-path*)
(define *load-paths*)

(and (= "-L" (car *arguments*))
(let ()
(pop *arguments*)
(set *load-path* (pop *arguments*))))
(while (= "-L" (car *arguments*))
(let ()
(pop *arguments*)
(push *load-paths* (pop *arguments*))))

(define-form next-argument () '(pop *arguments*))

Expand All @@ -1042,9 +1053,14 @@
(and (> (verbose) 1) (println "=> "result))
result))

(define-function find-and-read-in (name paths)
(if paths
(or (read (concat-string (car paths) name))
(find-and-read-in name (cdr paths)))
(read name)))

(define-function find-and-read (name)
(or (and *load-path* (read (concat-string *load-path* name)))
(read name)))
(find-and-read-in name *load-paths*))

(define-function load (name)
(let ((exps (find-and-read name)))
Expand Down Expand Up @@ -1090,4 +1106,3 @@
(define-method nth <pair> (n)
(while (< 0 (decr n)) (set self (cdr self)))
(car self))

120 changes: 90 additions & 30 deletions compilers/maru/maru/eval2.c
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
// last edited: 2012-12-11 20:00:42 by piumarta on emilia.local
// last edited: 2012-12-23 23:25:00 by piumarta on emilia.local

#define DEMO_BITS 1

Expand Down Expand Up @@ -92,7 +92,7 @@ struct Data { };
struct Long { long_t bits; };
struct Double { double bits; };
struct String { oop size; wchar_t *bits; }; /* bits is in managed memory */
struct Symbol { wchar_t *bits; };
struct Symbol { wchar_t *bits; int flags};
struct Pair { oop head, tail, source; };
struct Array { oop size, _array; };
struct Expr { oop name, definition, environment, profile; };
Expand Down Expand Up @@ -183,7 +183,7 @@ static char *argv0;
static oop symbols= nil, globals= nil, globalNamespace= nil, expanders= nil, encoders= nil, evaluators= nil, applicators= nil, backtrace= nil, arguments= nil, input= nil, output= nil;
static int traceDepth= 0;
static oop traceStack= nil, currentPath= nil, currentLine= nil, currentSource= nil;
static oop s_locals= nil, s_set= nil, s_define= nil, s_let= nil, s_lambda= nil, s_quote= nil, s_quasiquote= nil, s_unquote= nil, s_unquote_splicing= nil, s_t= nil, s_dot= nil, s_bracket= nil, s_brace= nil, s_main= nil;
static oop s_locals= nil, s_set= nil, s_define= nil, s_let= nil, s_lambda= nil, s_quote= nil, s_quasiquote= nil, s_unquote= nil, s_unquote_splicing= nil, s_t= nil, s_dot= nil, s_etc= nil, s_bracket= nil, s_brace= nil, s_main= nil;
// static oop f_set= nil, f_quote= nil, f_lambda= nil, f_let= nil, f_define;

static int opt_b= 0, opt_g= 0, opt_O= 0, opt_p= 0, opt_v= 0;
Expand Down Expand Up @@ -1091,6 +1091,33 @@ static void setSource(oop obj, oop src)
setSource(getTail(obj), src);
}

static oop getSource(oop exp)
{
if (is(Pair, exp)) {
oop src= get(exp, Pair,source);
if (nil != src) {
oop path= car(src);
oop line= cdr(src);
if (is(String, path) && is(Long, line))
return src;
}
}
return nil;
}

static int fprintSource(FILE *stream, oop src)
{
if (nil != src) {
return fprintf(stream, "%ls:%ld", get(car(src), String,bits), getLong(cdr(src)));
}
return 0;
}

static int printSource(oop exp)
{
return fprintSource(stdout, getSource(exp));
}

static oop exlist(oop obj, oop env);

static oop findFormFunction(oop env, oop var)
Expand Down Expand Up @@ -1165,13 +1192,27 @@ static oop exlist(oop list, oop env)
return head;
}

static int encodeIndent= 16;

static oop enlist(oop obj, oop env);

static oop encode(oop obj, oop env)
static oop encodeFrom(oop from, oop obj, oop env)
{
switch (getType(obj)) {
case Symbol: {
if (nil == findVariable(env, obj)) oprintf("warning: possibly undefined: %P\n", obj);
if (nil == findVariable(env, obj)) {
int flags= get(obj, Symbol,flags);
if (0 == (1 & flags)) {
set(obj, Symbol,flags, 1 | flags);
oop src= getSource(from);
if (nil != src) {
int i= fprintSource(stderr, getSource(from));
if (i > encodeIndent) encodeIndent= i;
while (i++ <= encodeIndent) putc(' ', stderr);
}
oprintf("warning: possibly undefined: %P\n", obj);
}
}
break;
}
case Pair: {
Expand All @@ -1186,8 +1227,10 @@ static oop encode(oop obj, oop env)
else if (head == s_lambda) { GC_PROTECT(env);
oop bindings= cadr(obj);
while (isPair(bindings)) {
oop id= bindings;
while (isPair(id)) id= car(id);
env= cons(nil, env);
setHead(env, cons(car(bindings), nil));
setHead(env, cons(id, nil));
bindings= getTail(bindings);
}
if (is(Symbol, bindings)) {
Expand All @@ -1204,24 +1247,60 @@ static oop encode(oop obj, oop env)
}
bindings= cadr(obj);
while (isPair(bindings)) {
oop id= bindings;
while (isPair(id)) id= car(id);
env= cons(nil, env);
setHead(env, cons(caar(bindings), nil));
setHead(env, cons(id, nil));
bindings= getTail(bindings);
}
enlist(cddr(obj), env); GC_UNPROTECT(env);
}
else
else {
enlist(obj, env);
if (is(Symbol, head)) {
oop val= lookup(getVar(globals), head);
if (is(Expr, val)) {
oop formal= car(get(val, Expr,definition));
oop actual= cdr(obj);
while (isPair(formal) && isPair(actual)) {
if (s_etc == car(formal)) {
formal= actual= nil;
}
else {
formal= cdr(formal);
actual= cdr(actual);
}
}
if (is(Symbol, formal))
formal= actual= nil;
if (nil != formal || nil != actual) {
oop src= getSource(obj);
if (nil != src) {
int i= fprintSource(stderr, getSource(from));
if (i > encodeIndent) encodeIndent= i;
while (i++ <= encodeIndent) putc(' ', stderr);
}
oprintf("warning: argument mismatch: %P -> %P\n", obj, car(get(val, Expr,definition)));
}
// CHECK ARG LIST HERE
}
}
}
break;
}
}
return obj;
}

static oop encode(oop obj, oop env)
{
return encodeFrom(nil, obj, env);
}

static oop enlist(oop obj, oop env)
{
while (isPair(obj)) {
encode(getHead(obj), env);
encodeFrom(obj, getHead(obj), env);
obj= getTail(obj);
}
return obj;
Expand Down Expand Up @@ -1354,26 +1433,6 @@ static oop enlist(oop obj, oop env)
// return head;
// }

static int fprintSource(FILE *stream, oop exp)
{
if (is(Pair, exp)) {
oop src= get(exp, Pair,source);
if (nil != src) {
oop path= car(src);
oop line= cdr(src);
if (is(String, path) && is(Long, line)) {
return fprintf(stream, "%ls:%ld", get(path, String,bits), getLong(line));
}
}
}
return 0;
}

static int printSource(oop exp)
{
return fprintSource(stdout, exp);
}

static void vfoprintf(FILE *out, char *fmt, va_list ap)
{
int c;
Expand Down Expand Up @@ -1563,7 +1622,7 @@ static oop apply(oop fun, oop arguments, oop env)
oop body= cdr(defn);
if (opt_g) {
arrayAtPut(traceStack, traceDepth++, body);
if (traceDepth > 1000) fatal("infinite recursion suspected");
if (traceDepth > 2000) fatal("infinite recursion suspected");
}
while (is(Pair, body)) {
// if (opt_g) arrayAtPut(traceStack, traceDepth - 1, getHead(body));
Expand Down Expand Up @@ -3377,6 +3436,7 @@ int main(int argc, char **argv)
s_unquote_splicing = intern(L"unquote-splicing"); GC_add_root(&s_unquote_splicing );
s_t = intern(L"t"); GC_add_root(&s_t );
s_dot = intern(L"."); GC_add_root(&s_dot );
s_etc = intern(L"..."); GC_add_root(&s_etc );
s_bracket = intern(L"bracket"); GC_add_root(&s_bracket );
s_brace = intern(L"brace"); GC_add_root(&s_brace );
s_main = intern(L"*main*"); GC_add_root(&s_main );
Expand Down
12 changes: 7 additions & 5 deletions compilers/maru/maru/ir-gen-c.k
View file
Original file line number Diff line number Diff line change
Expand Up @@ -167,11 +167,13 @@
(print "))"))

(define-function ir-gen-c-unary (insn op gen)
(print "((")
(print-c-declaration (car self.type) ())
(print ")(")
(ir-gen-c (car (<ir-insn>-operands insn)) gen)
(print ")"))
(let* ((type (<ir-insn>-type insn))
(opd (car (<ir-insn>-operands insn))))
(print "("op"((")
(print-c-declaration type ()) ;;(print-c-declaration (car self.type) ())
(print ")(")
(ir-gen-c opd gen)
(print ")))")))

(define-method ir-gen-c <ir-neg> (gen) (ir-gen-c-unary self '- (car self.operands)))
(define-method ir-gen-c <ir-com> (gen) (ir-gen-c-unary self '~ (car self.operands)))
Expand Down
Loading

0 comments on commit 38cc894

Please sign in to comment.