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>