summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c16
-rw-r--r--src/cjr_print.sml20
-rw-r--r--src/settings.sig3
-rw-r--r--src/settings.sml6
4 files changed, 40 insertions, 5 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index a76497bb..27831011 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -9,6 +9,7 @@
#include <stdarg.h>
#include <assert.h>
#include <ctype.h>
+#include <limits.h>
#include <stdint.h>
#include <sys/types.h>
#include <sys/socket.h>
@@ -338,6 +339,8 @@ void uw_app_init(uw_app *app) {
app->client_init();
}
+int uw_time = 0;
+
// Single-request state
@@ -427,6 +430,8 @@ struct uw_context {
char *current_url;
+ int deadline;
+
char error_message[ERROR_BUF_LEN];
};
@@ -484,6 +489,8 @@ uw_context uw_init() {
ctx->current_url = "";
+ ctx->deadline = INT_MAX;
+
return ctx;
}
@@ -3343,3 +3350,12 @@ uw_Basis_string uw_Basis_currentUrl(uw_context ctx) {
void uw_set_currentUrl(uw_context ctx, char *s) {
ctx->current_url = s;
}
+
+void uw_set_deadline(uw_context ctx, int n) {
+ ctx->deadline = n;
+}
+
+void uw_check_deadline(uw_context ctx) {
+ if (uw_time > ctx->deadline)
+ uw_error(ctx, FATAL, "Maximum running time exceeded");
+}
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index faf5f7b2..360ecb5c 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2009, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -1685,6 +1685,13 @@ fun p_exp' par env (e, loc) =
string "acc;",
newline,
newline,
+
+ if Settings.getDeadlines () then
+ box [string "uw_check_deadline(ctx);",
+ newline]
+ else
+ box [],
+
p_list_sepi (box []) (fn i =>
fn (proj, t) =>
box [string "__uwr_r_",
@@ -1934,7 +1941,7 @@ fun p_exp' par env (e, loc) =
and p_exp env = p_exp' false env
-fun p_fun env (fx, n, args, ran, e) =
+fun p_fun isRec env (fx, n, args, ran, e) =
let
val nargs = length args
val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
@@ -1954,6 +1961,11 @@ fun p_fun env (fx, n, args, ran, e) =
space,
string "{",
newline,
+ if isRec andalso Settings.getDeadlines () then
+ box [string "uw_check_deadline(ctx);",
+ newline]
+ else
+ box [],
box [string "return(",
p_exp env' e,
string ");"],
@@ -2060,7 +2072,7 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
p_exp env e,
string ";"]
- | DFun vi => p_fun env vi
+ | DFun vi => p_fun false env vi
| DFunRec vis =>
let
val env = E.declBinds env dAll
@@ -2077,7 +2089,7 @@ fun p_decl env (dAll as (d, _) : decl) =
(fn (_, dom) => p_typ env dom) args,
string ");"]) vis,
newline,
- p_list_sep newline (p_fun env) vis,
+ p_list_sep newline (p_fun true env) vis,
newline]
end
| DTable (x, _, pk, csts) => box [string "/* SQL table ",
diff --git a/src/settings.sig b/src/settings.sig
index 12182ae6..f3a4379e 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -187,4 +187,7 @@ signature SETTINGS = sig
val setStaticLinking : bool -> unit
val getStaticLinking : unit -> bool
+ val setDeadlines : bool -> unit
+ val getDeadlines : unit -> bool
+
end
diff --git a/src/settings.sml b/src/settings.sml
index 03b7fd6d..5edfb3ff 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2009, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -436,4 +436,8 @@ val staticLinking = ref false
fun setStaticLinking b = staticLinking := b
fun getStaticLinking () = !staticLinking
+val deadlines = ref false
+fun setDeadlines b = deadlines := b
+fun getDeadlines () = !deadlines
+
end