Mercurial > urweb
changeset 317:6a4e365db60c
Fix memory bounds checks; specialization of multi-argument polymorphic function works
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 11 Sep 2008 10:34:47 -0400 |
| parents | 04ebfe929a98 |
| children | 60907c06b4c4 |
| files | src/c/urweb.c src/compiler.sml tests/specialize.ur |
| diffstat | 3 files changed, 29 insertions(+), 8 deletions(-) [+] |
line wrap: on
line diff
--- a/src/c/urweb.c Thu Sep 11 10:14:59 2008 -0400 +++ b/src/c/urweb.c Thu Sep 11 10:34:47 2008 -0400 @@ -145,13 +145,16 @@ static void uw_check_heap(uw_context ctx, size_t extra) { if (ctx->heap_back - ctx->heap_front < extra) { - size_t desired = ctx->heap_back - ctx->heap_front + extra, next; + size_t desired = ctx->heap_back - ctx->heap + extra, next; char *new_heap; - for (next = ctx->heap_back - ctx->heap_front; next < desired; next *= 2); + next = ctx->heap_back - ctx->heap; + if (next == 0) + next = 1; + for (; next < desired; next *= 2); new_heap = realloc(ctx->heap, next); - ctx->heap_front = new_heap; + ctx->heap_front = new_heap + (ctx->heap_back - ctx->heap_front); ctx->heap_back = new_heap + next; if (new_heap != ctx->heap) { @@ -192,14 +195,17 @@ } static void uw_check(uw_context ctx, size_t extra) { - size_t desired = ctx->page_back - ctx->page_front + extra, next; + size_t desired = ctx->page_back - ctx->page + extra, next; char *new_page; - for (next = ctx->page_back - ctx->page_front; next < desired; next *= 2); + next = ctx->page_back - ctx->page; + if (next == 0) + next = 1; + for (; next < desired; next *= 2); new_page = realloc(ctx->page, next); ctx->page_front = new_page + (ctx->page_front - ctx->page); - ctx->page_back = new_page + (ctx->page_back - ctx->page); + ctx->page_back = new_page + next; ctx->page = new_page; }
--- a/src/compiler.sml Thu Sep 11 10:14:59 2008 -0400 +++ b/src/compiler.sml Thu Sep 11 10:34:47 2008 -0400 @@ -481,8 +481,8 @@ fun compileC {cname, oname, ename} = let - val compile = "gcc -Wstrict-prototypes -Werror -s -O3 -I include -c " ^ cname ^ " -o " ^ oname - val link = "gcc -Werror -s -O3 -pthread -lpq clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename + val compile = "gcc -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname + val link = "gcc -Werror -O3 -pthread -lpq clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename in if not (OS.Process.isSuccess (OS.Process.system compile)) then print "C compilation failed\n"
--- a/tests/specialize.ur Thu Sep 11 10:14:59 2008 -0400 +++ b/tests/specialize.ur Thu Sep 11 10:34:47 2008 -0400 @@ -10,18 +10,33 @@ Nil => ls2 | Cons (x, ls1') => Cons (x, append ls1' ls2) +fun pairAppend (t1 ::: Type) (t2 ::: Type) (ls1 : list (t1 * t2)) (ls2 : list (t1 * t2)) : list (t1 * t2) = + case ls1 of + Nil => ls2 + | Cons (x, ls1') => Cons (x, pairAppend ls1' ls2) + fun delist (ls : list string) : xml body [] [] = case ls of Nil => <body>Nil</body> | Cons (h, t) => <body>{cdata h} :: {delist t}</body> +fun pairDelist (ls : list (string * int)) : xml body [] [] = + case ls of + Nil => <body>Nil</body> + | Cons ((s, n), t) => <body>({cdata s}, {cdata (show _ n)}) :: {pairDelist t}</body> + val ls = Cons ("X", Cons ("Y", Cons ("Z", Nil))) val ls' = Cons ("A", Cons ("B", Nil)) +val pls = Cons (("X", 1), Cons (("Y", 2), Cons (("Z", 3), Nil))) +val pls' = Cons (("A", 1), Cons (("B", 2), Nil)) + fun main () : transaction page = return <html><body> {if isNil ls then <body>It's Nil.</body> else <body>It's not Nil.</body>} <p>{delist (append ls' ls)}</p> + + <p>{pairDelist (pairAppend pls' pls)}</p> </body></html>