Mercurial > urweb
changeset 2304:6fb9232ade99
Merge Sqlcache
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sun, 20 Dec 2015 14:18:52 -0500 |
| parents | 1091227f535a 42079884e34a |
| children | 9083b44bad0a |
| files | bin/.dir src/c/urweb.c src/cjr_print.sml src/compiler.sig src/compiler.sml src/iflow.sml src/jscomp.sml src/main.mlton.sml src/settings.sig src/settings.sml src/sources |
| diffstat | 50 files changed, 4918 insertions(+), 509 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/bench.lua Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,25 @@ +math.randomseed(os.time()) + +p = 0.25 +n = 2000 + +function init(args) + if args[1] then + p = tonumber(args[1]) + end + if args[2] then + n = tonumber(args[2]) + end +end + +function request() + path = "/Bench/" + if math.random() < p then + path = path .. "flush" + else + path = path .. "check" + end + id = math.random(n) + path = path .. "/" .. id + return wrk.format(nil, path) +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/bench.ur Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,16 @@ +table tab : {Id : int, Val : int} PRIMARY KEY Id + +fun check id = + res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); + return <xml><body> + Value at {[id]} is + {case res of + None => <xml>unknown</xml> + | Some row => <xml>{[row.Tab.Val]}</xml>}. + </body></xml> + +fun flush id = + dml (UPDATE tab SET Val = Val + 1 WHERE Id = {[id]}); + return <xml><body> + Incremented value at {[id]} (if it exists). + </body></xml>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/bench.urp Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,6 @@ +database host=localhost +sql bench.sql +safeGet Bench/flush +minHeap 4096 + +bench
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/bench.urs Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,2 @@ +val check : int -> transaction page +val flush : int -> transaction page
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/some-results.txt Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,198 @@ +~/Dev/UrWeb/caching-tests +$ urweb bench +~/Dev/UrWeb/caching-tests +$ ./bench.exe -q & +[1] 24466 +~/Dev/UrWeb/caching-tests +$ Initializing +Initializing +Initializing +wrk -d 2 http://localhost:8080/Bench/ -s bench.lua -- 0.5 +Running 2s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 1.41ms 320.22us 2.86ms 68.44% + Req/Sec 3.32k 696.42 4.25k 78.05% + 13526 requests in 2.10s, 4.81MB read +Requests/sec: 6439.96 +Transfer/sec: 2.29MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 1.08ms 250.98us 2.64ms 66.33% + Req/Sec 4.34k 704.72 6.84k 81.09% + 86850 requests in 10.10s, 30.70MB read +Requests/sec: 8598.75 +Transfer/sec: 3.04MB +~/Dev/UrWeb/caching-tests +$ fg +./bench.exe -q + C-c C-cExiting.... +~/Dev/UrWeb/caching-tests +$ ./bench.exe -q -t 2 & +[1] 24514 +~/Dev/UrWeb/caching-tests +$ Initializing +Initializing +Initializing +Initializing + +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 370.59us 90.83us 2.14ms 71.69% + Req/Sec 11.34k 1.19k 16.34k 72.64% + 226734 requests in 10.10s, 80.15MB read +Requests/sec: 22449.54 +Transfer/sec: 7.94MB +~/Dev/UrWeb/caching-tests +$ fg +./bench.exe -q -t 2 + C-c C-cExiting.... +~/Dev/UrWeb/caching-tests +$ urweb bench -sqlcache +~/Dev/UrWeb/caching-tests +$ ./bench.exe -q & +[1] 24548 +~/Dev/UrWeb/caching-tests +$ Initializing +Initializing +Initializing + +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 0.98ms 322.48us 4.68ms 71.58% + Req/Sec 4.71k 706.11 7.06k 69.31% + 94654 requests in 10.10s, 33.46MB read +Requests/sec: 9371.66 +Transfer/sec: 3.31MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 0.86ms 354.48us 7.31ms 71.15% + Req/Sec 5.21k 740.74 7.83k 68.81% + 104823 requests in 10.10s, 37.06MB read +Requests/sec: 10378.81 +Transfer/sec: 3.67MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 703.16us 339.13us 2.82ms 68.28% + Req/Sec 6.10k 0.96k 10.43k 83.08% + 121961 requests in 10.10s, 43.12MB read +Requests/sec: 12074.21 +Transfer/sec: 4.27MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 637.87us 348.05us 2.81ms 68.34% + Req/Sec 6.63k 1.12k 10.99k 73.76% + 133289 requests in 10.10s, 47.12MB read +Requests/sec: 13197.03 +Transfer/sec: 4.67MB +~/Dev/UrWeb/caching-tests +$ fg +./bench.exe -q + C-c C-cExiting.... +~/Dev/UrWeb/caching-tests +$ ./bench.exe -q -t 2 & +[1] 24616 +~/Dev/UrWeb/caching-tests +$ Initializing +Initializing +Initializing +Initializing + +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 0.98ms 436.87us 8.57ms 73.73% + Req/Sec 4.69k 1.05k 7.41k 62.87% + 94186 requests in 10.10s, 33.30MB read +Requests/sec: 9325.40 +Transfer/sec: 3.30MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 679.74us 357.72us 7.69ms 72.78% + Req/Sec 6.36k 1.23k 9.83k 70.65% + 127238 requests in 10.10s, 44.98MB read +Requests/sec: 12598.06 +Transfer/sec: 4.45MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 598.29us 351.32us 3.00ms 69.43% + Req/Sec 6.86k 1.01k 11.33k 75.50% + 136554 requests in 10.00s, 48.28MB read +Requests/sec: 13655.22 +Transfer/sec: 4.83MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 521.06us 331.23us 3.73ms 68.90% + Req/Sec 7.49k 1.20k 12.64k 85.07% + 149875 requests in 10.10s, 52.98MB read +Requests/sec: 14839.52 +Transfer/sec: 5.25MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 504.89us 347.06us 5.62ms 69.33% + Req/Sec 7.64k 0.94k 11.95k 69.80% + 153398 requests in 10.10s, 54.23MB read +Requests/sec: 15189.01 +Transfer/sec: 5.37MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 454.99us 315.26us 2.87ms 68.79% + Req/Sec 8.24k 1.20k 12.83k 80.10% + 164779 requests in 10.10s, 58.25MB read +Requests/sec: 16314.84 +Transfer/sec: 5.77MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 466.26us 326.63us 2.86ms 68.52% + Req/Sec 8.07k 1.04k 13.56k 74.13% + 161404 requests in 10.10s, 57.06MB read +Requests/sec: 15981.72 +Transfer/sec: 5.65MB +~/Dev/UrWeb/caching-tests +$ wrk http://localhost:8080/Bench/ -s bench.lua -- 0.1 100000 +Running 10s test @ http://localhost:8080/Bench/ + 2 threads and 10 connections + Thread Stats Avg Stdev Max +/- Stdev + Latency 458.75us 319.02us 3.11ms 68.07% + Req/Sec 8.15k 768.18 11.30k 69.80% + 163930 requests in 10.10s, 57.95MB read +Requests/sec: 16231.27 +Transfer/sec: 5.74MB
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/test.ur Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,111 @@ +table tab : {Id : int, Val : int, Foo : int} PRIMARY KEY Id + +fun cache id = + res <- oneOrNoRows (SELECT A.Val FROM (tab AS A JOIN tab AS B ON A.Id = B.Id) + WHERE B.Id = {[id]}); + return <xml><body> + cache + {case res of + None => <xml>?</xml> + | Some row => <xml>{[row.A.Val]}</xml>} + </body></xml> + +(* fun cacheAlt id = *) +(* res <- oneOrNoRows (SELECT Q.Id *) +(* FROM (SELECT Tab.Id AS Id FROM tab WHERE Tab.Id = {[id]}) *) +(* AS Q); *) +(* return <xml><body> *) +(* cacheAlt *) +(* {case res of *) +(* None => <xml>?</xml> *) +(* | Some row => <xml>{[row.Q.Id]}</xml>} *) +(* </body></xml> *) + +(* fun sillyRecursive {Id = id : int, FooBar = fooBar} = *) +(* if fooBar <= 0 *) +(* then 0 *) +(* else 1 + sillyRecursive {Id = id, FooBar = fooBar - 1} *) + +(* fun cacheR (r : {Id : int, FooBar : int}) = *) +(* res <- oneOrNoRows (SELECT tab.Val *) +(* FROM tab *) +(* WHERE tab.Id = {[r.Id]}); *) +(* return <xml><body> *) +(* cacheR {[r.FooBar]} *) +(* {case res of *) +(* None => <xml>?</xml> *) +(* | Some row => <xml>{[row.Tab.Val]}</xml>} *) +(* </body></xml> *) + +(* fun cache2 id v = *) +(* res <- oneOrNoRows (SELECT tab.Val *) +(* FROM tab *) +(* WHERE tab.Id = {[id]} AND tab.Val = {[v]}); *) +(* return <xml><body> *) +(* Reading {[id]}. *) +(* {case res of *) +(* None => <xml>Nope, that's not it.</xml> *) +(* | Some _ => <xml>Hooray! You guessed it!</xml>} *) +(* </body></xml> *) + +(* fun cache2 id1 id2 = *) +(* res1 <- oneOrNoRows (SELECT tab.Val *) +(* FROM tab *) +(* WHERE tab.Id = {[id1]}); *) +(* res2 <- oneOrNoRows (SELECT tab.Val *) +(* FROM tab *) +(* WHERE tab.Id = {[id2]}); *) +(* return <xml><body> *) +(* Reading {[id1]} and {[id2]}. *) +(* {case (res1, res2) of *) +(* (Some _, Some _) => <xml>Both are there.</xml> *) +(* | _ => <xml>One of them is missing.</xml>} *) +(* </body></xml> *) + +fun flush id = + dml (UPDATE tab + SET Val = Val * (Id + 2) / Val - 3 + WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); + return <xml><body> + Changed {[id]}! + </body></xml> + +(* fun flash id = *) +(* dml (UPDATE tab *) +(* SET Foo = Val *) +(* WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); *) +(* return <xml><body> *) +(* Maybe changed {[id]}? *) +(* </body></xml> *) + +(* fun floosh id = *) +(* dml (UPDATE tab *) +(* SET Id = {[id + 1]} *) +(* WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); *) +(* return <xml><body> *) +(* Shifted {[id]}! *) +(* </body></xml> *) + +(* val flush17 = *) +(* dml (UPDATE tab *) +(* SET Val = Val * (Id + 2) / Val - 3 *) +(* WHERE Id = 17); *) +(* return <xml><body> *) +(* Changed specifically 17! *) +(* </body></xml> *) + +(* fun flush id = *) +(* res <- oneOrNoRows (SELECT tab.Val *) +(* FROM tab *) +(* WHERE tab.Id = {[id]}); *) +(* (case res of *) +(* None => dml (INSERT INTO tab (Id, Val) *) +(* VALUES ({[id]}, 0)) *) +(* | Some row => dml (UPDATE tab *) +(* SET Val = {[row.Tab.Val + 1]} *) +(* WHERE Id = {[id]} OR Id = {[id + 1]})); *) +(* return <xml><body> *) +(* {case res of *) +(* None => <xml>Initialized {[id]}!</xml> *) +(* | Some row => <xml>Incremented {[id]}!</xml>} *) +(* </body></xml> *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/test.urp Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,9 @@ +database host=localhost +sql test.sql +safeGet Test/flush +# safeGet Test/flash +# safeGet Test/floosh +# safeGet Test/flush17 +minHeap 4096 + +test
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/test.urs Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,8 @@ +val cache : int -> transaction page +(* val cacheAlt : int -> transaction page *) +(* val cacheR : {Id : int, FooBar : int} -> transaction page *) +(* val cache2 : int -> int -> transaction page *) +val flush : int -> transaction page +(* val flash : int -> transaction page *) +(* val floosh : int -> transaction page *) +(* val flush17 : transaction page *)
--- a/include/urweb/types_cpp.h Sun Dec 20 13:41:35 2015 -0500 +++ b/include/urweb/types_cpp.h Sun Dec 20 14:18:52 2015 -0500 @@ -119,4 +119,27 @@ char *start, *front, *back; } uw_buffer; +// Caching + +#include <pthread.h> +#include "uthash.h" + +typedef struct uw_Sqlcache_Value { + char *result; + char *output; + unsigned long timeValid; +} uw_Sqlcache_Value; + +typedef struct uw_Sqlcache_Entry uw_Sqlcache_Entry; + +typedef struct uw_Sqlcache_Cache { + pthread_rwlock_t lockOut; + pthread_rwlock_t lockIn; + uw_Sqlcache_Entry *table; + unsigned long timeInvalid; + unsigned long timeNow; + size_t numKeys; + UT_hash_handle hh; +} uw_Sqlcache_Cache; + #endif
--- a/include/urweb/urweb_cpp.h Sun Dec 20 13:41:35 2015 -0500 +++ b/include/urweb/urweb_cpp.h Sun Dec 20 14:18:52 2015 -0500 @@ -78,6 +78,10 @@ void uw_write(struct uw_context *, const char*); +// For caching. +void uw_recordingStart(struct uw_context *); +char *uw_recordingRead(struct uw_context *); + uw_Basis_source uw_Basis_new_client_source(struct uw_context *, uw_Basis_string); uw_unit uw_Basis_set_client_source(struct uw_context *, uw_Basis_source, uw_Basis_string); @@ -400,4 +404,12 @@ void uw_Basis_writec(struct uw_context *, char); +// Sqlcache. + +void *uw_Sqlcache_rlock(struct uw_context *, uw_Sqlcache_Cache *); +void *uw_Sqlcache_wlock(struct uw_context *, uw_Sqlcache_Cache *); +uw_Sqlcache_Value *uw_Sqlcache_check(struct uw_context *, uw_Sqlcache_Cache *, char **); +void *uw_Sqlcache_store(struct uw_context *, uw_Sqlcache_Cache *, char **, uw_Sqlcache_Value *); +void *uw_Sqlcache_flush(struct uw_context *, uw_Sqlcache_Cache *, char **); + #endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/include/urweb/uthash.h Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,963 @@ +/* +Copyright (c) 2003-2014, Troy D. Hanson http://troydhanson.github.com/uthash/ +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ + +#ifndef UTHASH_H +#define UTHASH_H + +#include <string.h> /* memcmp,strlen */ +#include <stddef.h> /* ptrdiff_t */ +#include <stdlib.h> /* exit() */ + +/* These macros use decltype or the earlier __typeof GNU extension. + As decltype is only available in newer compilers (VS2010 or gcc 4.3+ + when compiling c++ source) this code uses whatever method is needed + or, for VS2008 where neither is available, uses casting workarounds. */ +#if defined(_MSC_VER) /* MS compiler */ +#if _MSC_VER >= 1600 && defined(__cplusplus) /* VS2010 or newer in C++ mode */ +#define DECLTYPE(x) (decltype(x)) +#else /* VS2008 or older (or VS2010 in C mode) */ +#define NO_DECLTYPE +#define DECLTYPE(x) +#endif +#elif defined(__BORLANDC__) || defined(__LCC__) || defined(__WATCOMC__) +#define NO_DECLTYPE +#define DECLTYPE(x) +#else /* GNU, Sun and other compilers */ +#define DECLTYPE(x) (__typeof(x)) +#endif + +#ifdef NO_DECLTYPE +#define DECLTYPE_ASSIGN(dst,src) \ +do { \ + char **_da_dst = (char**)(&(dst)); \ + *_da_dst = (char*)(src); \ +} while(0) +#else +#define DECLTYPE_ASSIGN(dst,src) \ +do { \ + (dst) = DECLTYPE(dst)(src); \ +} while(0) +#endif + +/* a number of the hash function use uint32_t which isn't defined on Pre VS2010 */ +#if defined (_WIN32) +#if defined(_MSC_VER) && _MSC_VER >= 1600 +#include <stdint.h> +#elif defined(__WATCOMC__) +#include <stdint.h> +#else +typedef unsigned int uint32_t; +typedef unsigned char uint8_t; +#endif +#else +#include <stdint.h> +#endif + +#define UTHASH_VERSION 1.9.9 + +#ifndef uthash_fatal +#define uthash_fatal(msg) exit(-1) /* fatal error (out of memory,etc) */ +#endif +#ifndef uthash_malloc +#define uthash_malloc(sz) malloc(sz) /* malloc fcn */ +#endif +#ifndef uthash_free +#define uthash_free(ptr,sz) free(ptr) /* free fcn */ +#endif + +#ifndef uthash_noexpand_fyi +#define uthash_noexpand_fyi(tbl) /* can be defined to log noexpand */ +#endif +#ifndef uthash_expand_fyi +#define uthash_expand_fyi(tbl) /* can be defined to log expands */ +#endif + +/* initial number of buckets */ +#define HASH_INITIAL_NUM_BUCKETS 32U /* initial number of buckets */ +#define HASH_INITIAL_NUM_BUCKETS_LOG2 5U /* lg2 of initial number of buckets */ +#define HASH_BKT_CAPACITY_THRESH 10U /* expand when bucket count reaches */ + +/* calculate the element whose hash handle address is hhe */ +#define ELMT_FROM_HH(tbl,hhp) ((void*)(((char*)(hhp)) - ((tbl)->hho))) + +#define HASH_FIND(hh,head,keyptr,keylen,out) \ +do { \ + out=NULL; \ + if (head != NULL) { \ + unsigned _hf_bkt,_hf_hashv; \ + HASH_FCN(keyptr,keylen, (head)->hh.tbl->num_buckets, _hf_hashv, _hf_bkt); \ + if (HASH_BLOOM_TEST((head)->hh.tbl, _hf_hashv) != 0) { \ + HASH_FIND_IN_BKT((head)->hh.tbl, hh, (head)->hh.tbl->buckets[ _hf_bkt ], \ + keyptr,keylen,out); \ + } \ + } \ +} while (0) + +#ifdef HASH_BLOOM +#define HASH_BLOOM_BITLEN (1UL << HASH_BLOOM) +#define HASH_BLOOM_BYTELEN (HASH_BLOOM_BITLEN/8UL) + (((HASH_BLOOM_BITLEN%8UL)!=0UL) ? 1UL : 0UL) +#define HASH_BLOOM_MAKE(tbl) \ +do { \ + (tbl)->bloom_nbits = HASH_BLOOM; \ + (tbl)->bloom_bv = (uint8_t*)uthash_malloc(HASH_BLOOM_BYTELEN); \ + if (!((tbl)->bloom_bv)) { uthash_fatal( "out of memory"); } \ + memset((tbl)->bloom_bv, 0, HASH_BLOOM_BYTELEN); \ + (tbl)->bloom_sig = HASH_BLOOM_SIGNATURE; \ +} while (0) + +#define HASH_BLOOM_FREE(tbl) \ +do { \ + uthash_free((tbl)->bloom_bv, HASH_BLOOM_BYTELEN); \ +} while (0) + +#define HASH_BLOOM_BITSET(bv,idx) (bv[(idx)/8U] |= (1U << ((idx)%8U))) +#define HASH_BLOOM_BITTEST(bv,idx) (bv[(idx)/8U] & (1U << ((idx)%8U))) + +#define HASH_BLOOM_ADD(tbl,hashv) \ + HASH_BLOOM_BITSET((tbl)->bloom_bv, (hashv & (uint32_t)((1ULL << (tbl)->bloom_nbits) - 1U))) + +#define HASH_BLOOM_TEST(tbl,hashv) \ + HASH_BLOOM_BITTEST((tbl)->bloom_bv, (hashv & (uint32_t)((1ULL << (tbl)->bloom_nbits) - 1U))) + +#else +#define HASH_BLOOM_MAKE(tbl) +#define HASH_BLOOM_FREE(tbl) +#define HASH_BLOOM_ADD(tbl,hashv) +#define HASH_BLOOM_TEST(tbl,hashv) (1) +#define HASH_BLOOM_BYTELEN 0U +#endif + +#define HASH_MAKE_TABLE(hh,head) \ +do { \ + (head)->hh.tbl = (UT_hash_table*)uthash_malloc( \ + sizeof(UT_hash_table)); \ + if (!((head)->hh.tbl)) { uthash_fatal( "out of memory"); } \ + memset((head)->hh.tbl, 0, sizeof(UT_hash_table)); \ + (head)->hh.tbl->tail = &((head)->hh); \ + (head)->hh.tbl->num_buckets = HASH_INITIAL_NUM_BUCKETS; \ + (head)->hh.tbl->log2_num_buckets = HASH_INITIAL_NUM_BUCKETS_LOG2; \ + (head)->hh.tbl->hho = (char*)(&(head)->hh) - (char*)(head); \ + (head)->hh.tbl->buckets = (UT_hash_bucket*)uthash_malloc( \ + HASH_INITIAL_NUM_BUCKETS*sizeof(struct UT_hash_bucket)); \ + if (! (head)->hh.tbl->buckets) { uthash_fatal( "out of memory"); } \ + memset((head)->hh.tbl->buckets, 0, \ + HASH_INITIAL_NUM_BUCKETS*sizeof(struct UT_hash_bucket)); \ + HASH_BLOOM_MAKE((head)->hh.tbl); \ + (head)->hh.tbl->signature = HASH_SIGNATURE; \ +} while(0) + +#define HASH_ADD(hh,head,fieldname,keylen_in,add) \ + HASH_ADD_KEYPTR(hh,head,&((add)->fieldname),keylen_in,add) + +#define HASH_REPLACE(hh,head,fieldname,keylen_in,add,replaced) \ +do { \ + replaced=NULL; \ + HASH_FIND(hh,head,&((add)->fieldname),keylen_in,replaced); \ + if (replaced!=NULL) { \ + HASH_DELETE(hh,head,replaced); \ + } \ + HASH_ADD(hh,head,fieldname,keylen_in,add); \ +} while(0) + +#define HASH_ADD_KEYPTR(hh,head,keyptr,keylen_in,add) \ +do { \ + unsigned _ha_bkt; \ + (add)->hh.next = NULL; \ + (add)->hh.key = (char*)(keyptr); \ + (add)->hh.keylen = (unsigned)(keylen_in); \ + if (!(head)) { \ + head = (add); \ + (head)->hh.prev = NULL; \ + HASH_MAKE_TABLE(hh,head); \ + } else { \ + (head)->hh.tbl->tail->next = (add); \ + (add)->hh.prev = ELMT_FROM_HH((head)->hh.tbl, (head)->hh.tbl->tail); \ + (head)->hh.tbl->tail = &((add)->hh); \ + } \ + (head)->hh.tbl->num_items++; \ + (add)->hh.tbl = (head)->hh.tbl; \ + HASH_FCN(keyptr,keylen_in, (head)->hh.tbl->num_buckets, \ + (add)->hh.hashv, _ha_bkt); \ + HASH_ADD_TO_BKT((head)->hh.tbl->buckets[_ha_bkt],&(add)->hh); \ + HASH_BLOOM_ADD((head)->hh.tbl,(add)->hh.hashv); \ + HASH_EMIT_KEY(hh,head,keyptr,keylen_in); \ + HASH_FSCK(hh,head); \ +} while(0) + +#define HASH_TO_BKT( hashv, num_bkts, bkt ) \ +do { \ + bkt = ((hashv) & ((num_bkts) - 1U)); \ +} while(0) + +/* delete "delptr" from the hash table. + * "the usual" patch-up process for the app-order doubly-linked-list. + * The use of _hd_hh_del below deserves special explanation. + * These used to be expressed using (delptr) but that led to a bug + * if someone used the same symbol for the head and deletee, like + * HASH_DELETE(hh,users,users); + * We want that to work, but by changing the head (users) below + * we were forfeiting our ability to further refer to the deletee (users) + * in the patch-up process. Solution: use scratch space to + * copy the deletee pointer, then the latter references are via that + * scratch pointer rather than through the repointed (users) symbol. + */ +#define HASH_DELETE(hh,head,delptr) \ +do { \ + struct UT_hash_handle *_hd_hh_del; \ + if ( ((delptr)->hh.prev == NULL) && ((delptr)->hh.next == NULL) ) { \ + uthash_free((head)->hh.tbl->buckets, \ + (head)->hh.tbl->num_buckets*sizeof(struct UT_hash_bucket) ); \ + HASH_BLOOM_FREE((head)->hh.tbl); \ + uthash_free((head)->hh.tbl, sizeof(UT_hash_table)); \ + head = NULL; \ + } else { \ + unsigned _hd_bkt; \ + _hd_hh_del = &((delptr)->hh); \ + if ((delptr) == ELMT_FROM_HH((head)->hh.tbl,(head)->hh.tbl->tail)) { \ + (head)->hh.tbl->tail = \ + (UT_hash_handle*)((ptrdiff_t)((delptr)->hh.prev) + \ + (head)->hh.tbl->hho); \ + } \ + if ((delptr)->hh.prev != NULL) { \ + ((UT_hash_handle*)((ptrdiff_t)((delptr)->hh.prev) + \ + (head)->hh.tbl->hho))->next = (delptr)->hh.next; \ + } else { \ + DECLTYPE_ASSIGN(head,(delptr)->hh.next); \ + } \ + if (_hd_hh_del->next != NULL) { \ + ((UT_hash_handle*)((ptrdiff_t)_hd_hh_del->next + \ + (head)->hh.tbl->hho))->prev = \ + _hd_hh_del->prev; \ + } \ + HASH_TO_BKT( _hd_hh_del->hashv, (head)->hh.tbl->num_buckets, _hd_bkt); \ + HASH_DEL_IN_BKT(hh,(head)->hh.tbl->buckets[_hd_bkt], _hd_hh_del); \ + (head)->hh.tbl->num_items--; \ + } \ + HASH_FSCK(hh,head); \ +} while (0) + + +/* convenience forms of HASH_FIND/HASH_ADD/HASH_DEL */ +#define HASH_FIND_STR(head,findstr,out) \ + HASH_FIND(hh,head,findstr,(unsigned)strlen(findstr),out) +#define HASH_ADD_STR(head,strfield,add) \ + HASH_ADD(hh,head,strfield[0],(unsigned int)strlen(add->strfield),add) +#define HASH_REPLACE_STR(head,strfield,add,replaced) \ + HASH_REPLACE(hh,head,strfield[0],(unsigned)strlen(add->strfield),add,replaced) +#define HASH_FIND_INT(head,findint,out) \ + HASH_FIND(hh,head,findint,sizeof(int),out) +#define HASH_ADD_INT(head,intfield,add) \ + HASH_ADD(hh,head,intfield,sizeof(int),add) +#define HASH_REPLACE_INT(head,intfield,add,replaced) \ + HASH_REPLACE(hh,head,intfield,sizeof(int),add,replaced) +#define HASH_FIND_PTR(head,findptr,out) \ + HASH_FIND(hh,head,findptr,sizeof(void *),out) +#define HASH_ADD_PTR(head,ptrfield,add) \ + HASH_ADD(hh,head,ptrfield,sizeof(void *),add) +#define HASH_REPLACE_PTR(head,ptrfield,add,replaced) \ + HASH_REPLACE(hh,head,ptrfield,sizeof(void *),add,replaced) +#define HASH_DEL(head,delptr) \ + HASH_DELETE(hh,head,delptr) + +/* HASH_FSCK checks hash integrity on every add/delete when HASH_DEBUG is defined. + * This is for uthash developer only; it compiles away if HASH_DEBUG isn't defined. + */ +#ifdef HASH_DEBUG +#define HASH_OOPS(...) do { fprintf(stderr,__VA_ARGS__); exit(-1); } while (0) +#define HASH_FSCK(hh,head) \ +do { \ + struct UT_hash_handle *_thh; \ + if (head) { \ + unsigned _bkt_i; \ + unsigned _count; \ + char *_prev; \ + _count = 0; \ + for( _bkt_i = 0; _bkt_i < (head)->hh.tbl->num_buckets; _bkt_i++) { \ + unsigned _bkt_count = 0; \ + _thh = (head)->hh.tbl->buckets[_bkt_i].hh_head; \ + _prev = NULL; \ + while (_thh) { \ + if (_prev != (char*)(_thh->hh_prev)) { \ + HASH_OOPS("invalid hh_prev %p, actual %p\n", \ + _thh->hh_prev, _prev ); \ + } \ + _bkt_count++; \ + _prev = (char*)(_thh); \ + _thh = _thh->hh_next; \ + } \ + _count += _bkt_count; \ + if ((head)->hh.tbl->buckets[_bkt_i].count != _bkt_count) { \ + HASH_OOPS("invalid bucket count %u, actual %u\n", \ + (head)->hh.tbl->buckets[_bkt_i].count, _bkt_count); \ + } \ + } \ + if (_count != (head)->hh.tbl->num_items) { \ + HASH_OOPS("invalid hh item count %u, actual %u\n", \ + (head)->hh.tbl->num_items, _count ); \ + } \ + /* traverse hh in app order; check next/prev integrity, count */ \ + _count = 0; \ + _prev = NULL; \ + _thh = &(head)->hh; \ + while (_thh) { \ + _count++; \ + if (_prev !=(char*)(_thh->prev)) { \ + HASH_OOPS("invalid prev %p, actual %p\n", \ + _thh->prev, _prev ); \ + } \ + _prev = (char*)ELMT_FROM_HH((head)->hh.tbl, _thh); \ + _thh = ( _thh->next ? (UT_hash_handle*)((char*)(_thh->next) + \ + (head)->hh.tbl->hho) : NULL ); \ + } \ + if (_count != (head)->hh.tbl->num_items) { \ + HASH_OOPS("invalid app item count %u, actual %u\n", \ + (head)->hh.tbl->num_items, _count ); \ + } \ + } \ +} while (0) +#else +#define HASH_FSCK(hh,head) +#endif + +/* When compiled with -DHASH_EMIT_KEYS, length-prefixed keys are emitted to + * the descriptor to which this macro is defined for tuning the hash function. + * The app can #include <unistd.h> to get the prototype for write(2). */ +#ifdef HASH_EMIT_KEYS +#define HASH_EMIT_KEY(hh,head,keyptr,fieldlen) \ +do { \ + unsigned _klen = fieldlen; \ + write(HASH_EMIT_KEYS, &_klen, sizeof(_klen)); \ + write(HASH_EMIT_KEYS, keyptr, (unsigned long)fieldlen); \ +} while (0) +#else +#define HASH_EMIT_KEY(hh,head,keyptr,fieldlen) +#endif + +/* default to Jenkin's hash unless overridden e.g. DHASH_FUNCTION=HASH_SAX */ +#ifdef HASH_FUNCTION +#define HASH_FCN HASH_FUNCTION +#else +#define HASH_FCN HASH_JEN +#endif + +/* The Bernstein hash function, used in Perl prior to v5.6. Note (x<<5+x)=x*33. */ +#define HASH_BER(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _hb_keylen=(unsigned)keylen; \ + const unsigned char *_hb_key=(const unsigned char*)(key); \ + (hashv) = 0; \ + while (_hb_keylen-- != 0U) { \ + (hashv) = (((hashv) << 5) + (hashv)) + *_hb_key++; \ + } \ + bkt = (hashv) & (num_bkts-1U); \ +} while (0) + + +/* SAX/FNV/OAT/JEN hash functions are macro variants of those listed at + * http://eternallyconfuzzled.com/tuts/algorithms/jsw_tut_hashing.aspx */ +#define HASH_SAX(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _sx_i; \ + const unsigned char *_hs_key=(const unsigned char*)(key); \ + hashv = 0; \ + for(_sx_i=0; _sx_i < keylen; _sx_i++) { \ + hashv ^= (hashv << 5) + (hashv >> 2) + _hs_key[_sx_i]; \ + } \ + bkt = hashv & (num_bkts-1U); \ +} while (0) +/* FNV-1a variation */ +#define HASH_FNV(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _fn_i; \ + const unsigned char *_hf_key=(const unsigned char*)(key); \ + hashv = 2166136261U; \ + for(_fn_i=0; _fn_i < keylen; _fn_i++) { \ + hashv = hashv ^ _hf_key[_fn_i]; \ + hashv = hashv * 16777619U; \ + } \ + bkt = hashv & (num_bkts-1U); \ +} while(0) + +#define HASH_OAT(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _ho_i; \ + const unsigned char *_ho_key=(const unsigned char*)(key); \ + hashv = 0; \ + for(_ho_i=0; _ho_i < keylen; _ho_i++) { \ + hashv += _ho_key[_ho_i]; \ + hashv += (hashv << 10); \ + hashv ^= (hashv >> 6); \ + } \ + hashv += (hashv << 3); \ + hashv ^= (hashv >> 11); \ + hashv += (hashv << 15); \ + bkt = hashv & (num_bkts-1U); \ +} while(0) + +#define HASH_JEN_MIX(a,b,c) \ +do { \ + a -= b; a -= c; a ^= ( c >> 13 ); \ + b -= c; b -= a; b ^= ( a << 8 ); \ + c -= a; c -= b; c ^= ( b >> 13 ); \ + a -= b; a -= c; a ^= ( c >> 12 ); \ + b -= c; b -= a; b ^= ( a << 16 ); \ + c -= a; c -= b; c ^= ( b >> 5 ); \ + a -= b; a -= c; a ^= ( c >> 3 ); \ + b -= c; b -= a; b ^= ( a << 10 ); \ + c -= a; c -= b; c ^= ( b >> 15 ); \ +} while (0) + +#define HASH_JEN(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned _hj_i,_hj_j,_hj_k; \ + unsigned const char *_hj_key=(unsigned const char*)(key); \ + hashv = 0xfeedbeefu; \ + _hj_i = _hj_j = 0x9e3779b9u; \ + _hj_k = (unsigned)(keylen); \ + while (_hj_k >= 12U) { \ + _hj_i += (_hj_key[0] + ( (unsigned)_hj_key[1] << 8 ) \ + + ( (unsigned)_hj_key[2] << 16 ) \ + + ( (unsigned)_hj_key[3] << 24 ) ); \ + _hj_j += (_hj_key[4] + ( (unsigned)_hj_key[5] << 8 ) \ + + ( (unsigned)_hj_key[6] << 16 ) \ + + ( (unsigned)_hj_key[7] << 24 ) ); \ + hashv += (_hj_key[8] + ( (unsigned)_hj_key[9] << 8 ) \ + + ( (unsigned)_hj_key[10] << 16 ) \ + + ( (unsigned)_hj_key[11] << 24 ) ); \ + \ + HASH_JEN_MIX(_hj_i, _hj_j, hashv); \ + \ + _hj_key += 12; \ + _hj_k -= 12U; \ + } \ + hashv += (unsigned)(keylen); \ + switch ( _hj_k ) { \ + case 11: hashv += ( (unsigned)_hj_key[10] << 24 ); /* FALLTHROUGH */ \ + case 10: hashv += ( (unsigned)_hj_key[9] << 16 ); /* FALLTHROUGH */ \ + case 9: hashv += ( (unsigned)_hj_key[8] << 8 ); /* FALLTHROUGH */ \ + case 8: _hj_j += ( (unsigned)_hj_key[7] << 24 ); /* FALLTHROUGH */ \ + case 7: _hj_j += ( (unsigned)_hj_key[6] << 16 ); /* FALLTHROUGH */ \ + case 6: _hj_j += ( (unsigned)_hj_key[5] << 8 ); /* FALLTHROUGH */ \ + case 5: _hj_j += _hj_key[4]; /* FALLTHROUGH */ \ + case 4: _hj_i += ( (unsigned)_hj_key[3] << 24 ); /* FALLTHROUGH */ \ + case 3: _hj_i += ( (unsigned)_hj_key[2] << 16 ); /* FALLTHROUGH */ \ + case 2: _hj_i += ( (unsigned)_hj_key[1] << 8 ); /* FALLTHROUGH */ \ + case 1: _hj_i += _hj_key[0]; \ + } \ + HASH_JEN_MIX(_hj_i, _hj_j, hashv); \ + bkt = hashv & (num_bkts-1U); \ +} while(0) + +/* The Paul Hsieh hash function */ +#undef get16bits +#if (defined(__GNUC__) && defined(__i386__)) || defined(__WATCOMC__) \ + || defined(_MSC_VER) || defined (__BORLANDC__) || defined (__TURBOC__) +#define get16bits(d) (*((const uint16_t *) (d))) +#endif + +#if !defined (get16bits) +#define get16bits(d) ((((uint32_t)(((const uint8_t *)(d))[1])) << 8) \ + +(uint32_t)(((const uint8_t *)(d))[0]) ) +#endif +#define HASH_SFH(key,keylen,num_bkts,hashv,bkt) \ +do { \ + unsigned const char *_sfh_key=(unsigned const char*)(key); \ + uint32_t _sfh_tmp, _sfh_len = (uint32_t)keylen; \ + \ + unsigned _sfh_rem = _sfh_len & 3U; \ + _sfh_len >>= 2; \ + hashv = 0xcafebabeu; \ + \ + /* Main loop */ \ + for (;_sfh_len > 0U; _sfh_len--) { \ + hashv += get16bits (_sfh_key); \ + _sfh_tmp = ((uint32_t)(get16bits (_sfh_key+2)) << 11) ^ hashv; \ + hashv = (hashv << 16) ^ _sfh_tmp; \ + _sfh_key += 2U*sizeof (uint16_t); \ + hashv += hashv >> 11; \ + } \ + \ + /* Handle end cases */ \ + switch (_sfh_rem) { \ + case 3: hashv += get16bits (_sfh_key); \ + hashv ^= hashv << 16; \ + hashv ^= (uint32_t)(_sfh_key[sizeof (uint16_t)]) << 18; \ + hashv += hashv >> 11; \ + break; \ + case 2: hashv += get16bits (_sfh_key); \ + hashv ^= hashv << 11; \ + hashv += hashv >> 17; \ + break; \ + case 1: hashv += *_sfh_key; \ + hashv ^= hashv << 10; \ + hashv += hashv >> 1; \ + } \ + \ + /* Force "avalanching" of final 127 bits */ \ + hashv ^= hashv << 3; \ + hashv += hashv >> 5; \ + hashv ^= hashv << 4; \ + hashv += hashv >> 17; \ + hashv ^= hashv << 25; \ + hashv += hashv >> 6; \ + bkt = hashv & (num_bkts-1U); \ +} while(0) + +#ifdef HASH_USING_NO_STRICT_ALIASING +/* The MurmurHash exploits some CPU's (x86,x86_64) tolerance for unaligned reads. + * For other types of CPU's (e.g. Sparc) an unaligned read causes a bus error. + * MurmurHash uses the faster approach only on CPU's where we know it's safe. + * + * Note the preprocessor built-in defines can be emitted using: + * + * gcc -m64 -dM -E - < /dev/null (on gcc) + * cc -## a.c (where a.c is a simple test file) (Sun Studio) + */ +#if (defined(__i386__) || defined(__x86_64__) || defined(_M_IX86)) +#define MUR_GETBLOCK(p,i) p[i] +#else /* non intel */ +#define MUR_PLUS0_ALIGNED(p) (((unsigned long)p & 3UL) == 0UL) +#define MUR_PLUS1_ALIGNED(p) (((unsigned long)p & 3UL) == 1UL) +#define MUR_PLUS2_ALIGNED(p) (((unsigned long)p & 3UL) == 2UL) +#define MUR_PLUS3_ALIGNED(p) (((unsigned long)p & 3UL) == 3UL) +#define WP(p) ((uint32_t*)((unsigned long)(p) & ~3UL)) +#if (defined(__BIG_ENDIAN__) || defined(SPARC) || defined(__ppc__) || defined(__ppc64__)) +#define MUR_THREE_ONE(p) ((((*WP(p))&0x00ffffff) << 8) | (((*(WP(p)+1))&0xff000000) >> 24)) +#define MUR_TWO_TWO(p) ((((*WP(p))&0x0000ffff) <<16) | (((*(WP(p)+1))&0xffff0000) >> 16)) +#define MUR_ONE_THREE(p) ((((*WP(p))&0x000000ff) <<24) | (((*(WP(p)+1))&0xffffff00) >> 8)) +#else /* assume little endian non-intel */ +#define MUR_THREE_ONE(p) ((((*WP(p))&0xffffff00) >> 8) | (((*(WP(p)+1))&0x000000ff) << 24)) +#define MUR_TWO_TWO(p) ((((*WP(p))&0xffff0000) >>16) | (((*(WP(p)+1))&0x0000ffff) << 16)) +#define MUR_ONE_THREE(p) ((((*WP(p))&0xff000000) >>24) | (((*(WP(p)+1))&0x00ffffff) << 8)) +#endif +#define MUR_GETBLOCK(p,i) (MUR_PLUS0_ALIGNED(p) ? ((p)[i]) : \ + (MUR_PLUS1_ALIGNED(p) ? MUR_THREE_ONE(p) : \ + (MUR_PLUS2_ALIGNED(p) ? MUR_TWO_TWO(p) : \ + MUR_ONE_THREE(p)))) +#endif +#define MUR_ROTL32(x,r) (((x) << (r)) | ((x) >> (32 - (r)))) +#define MUR_FMIX(_h) \ +do { \ + _h ^= _h >> 16; \ + _h *= 0x85ebca6bu; \ + _h ^= _h >> 13; \ + _h *= 0xc2b2ae35u; \ + _h ^= _h >> 16; \ +} while(0) + +#define HASH_MUR(key,keylen,num_bkts,hashv,bkt) \ +do { \ + const uint8_t *_mur_data = (const uint8_t*)(key); \ + const int _mur_nblocks = (int)(keylen) / 4; \ + uint32_t _mur_h1 = 0xf88D5353u; \ + uint32_t _mur_c1 = 0xcc9e2d51u; \ + uint32_t _mur_c2 = 0x1b873593u; \ + uint32_t _mur_k1 = 0; \ + const uint8_t *_mur_tail; \ + const uint32_t *_mur_blocks = (const uint32_t*)(_mur_data+(_mur_nblocks*4)); \ + int _mur_i; \ + for(_mur_i = -_mur_nblocks; _mur_i!=0; _mur_i++) { \ + _mur_k1 = MUR_GETBLOCK(_mur_blocks,_mur_i); \ + _mur_k1 *= _mur_c1; \ + _mur_k1 = MUR_ROTL32(_mur_k1,15); \ + _mur_k1 *= _mur_c2; \ + \ + _mur_h1 ^= _mur_k1; \ + _mur_h1 = MUR_ROTL32(_mur_h1,13); \ + _mur_h1 = (_mur_h1*5U) + 0xe6546b64u; \ + } \ + _mur_tail = (const uint8_t*)(_mur_data + (_mur_nblocks*4)); \ + _mur_k1=0; \ + switch((keylen) & 3U) { \ + case 3: _mur_k1 ^= (uint32_t)_mur_tail[2] << 16; /* FALLTHROUGH */ \ + case 2: _mur_k1 ^= (uint32_t)_mur_tail[1] << 8; /* FALLTHROUGH */ \ + case 1: _mur_k1 ^= (uint32_t)_mur_tail[0]; \ + _mur_k1 *= _mur_c1; \ + _mur_k1 = MUR_ROTL32(_mur_k1,15); \ + _mur_k1 *= _mur_c2; \ + _mur_h1 ^= _mur_k1; \ + } \ + _mur_h1 ^= (uint32_t)(keylen); \ + MUR_FMIX(_mur_h1); \ + hashv = _mur_h1; \ + bkt = hashv & (num_bkts-1U); \ +} while(0) +#endif /* HASH_USING_NO_STRICT_ALIASING */ + +/* key comparison function; return 0 if keys equal */ +#define HASH_KEYCMP(a,b,len) memcmp(a,b,(unsigned long)(len)) + +/* iterate over items in a known bucket to find desired item */ +#define HASH_FIND_IN_BKT(tbl,hh,head,keyptr,keylen_in,out) \ +do { \ + if (head.hh_head != NULL) { DECLTYPE_ASSIGN(out,ELMT_FROM_HH(tbl,head.hh_head)); } \ + else { out=NULL; } \ + while (out != NULL) { \ + if ((out)->hh.keylen == (keylen_in)) { \ + if ((HASH_KEYCMP((out)->hh.key,keyptr,keylen_in)) == 0) { break; } \ + } \ + if ((out)->hh.hh_next != NULL) { DECLTYPE_ASSIGN(out,ELMT_FROM_HH(tbl,(out)->hh.hh_next)); } \ + else { out = NULL; } \ + } \ +} while(0) + +/* add an item to a bucket */ +#define HASH_ADD_TO_BKT(head,addhh) \ +do { \ + head.count++; \ + (addhh)->hh_next = head.hh_head; \ + (addhh)->hh_prev = NULL; \ + if (head.hh_head != NULL) { (head).hh_head->hh_prev = (addhh); } \ + (head).hh_head=addhh; \ + if ((head.count >= ((head.expand_mult+1U) * HASH_BKT_CAPACITY_THRESH)) \ + && ((addhh)->tbl->noexpand != 1U)) { \ + HASH_EXPAND_BUCKETS((addhh)->tbl); \ + } \ +} while(0) + +/* remove an item from a given bucket */ +#define HASH_DEL_IN_BKT(hh,head,hh_del) \ + (head).count--; \ + if ((head).hh_head == hh_del) { \ + (head).hh_head = hh_del->hh_next; \ + } \ + if (hh_del->hh_prev) { \ + hh_del->hh_prev->hh_next = hh_del->hh_next; \ + } \ + if (hh_del->hh_next) { \ + hh_del->hh_next->hh_prev = hh_del->hh_prev; \ + } + +/* Bucket expansion has the effect of doubling the number of buckets + * and redistributing the items into the new buckets. Ideally the + * items will distribute more or less evenly into the new buckets + * (the extent to which this is true is a measure of the quality of + * the hash function as it applies to the key domain). + * + * With the items distributed into more buckets, the chain length + * (item count) in each bucket is reduced. Thus by expanding buckets + * the hash keeps a bound on the chain length. This bounded chain + * length is the essence of how a hash provides constant time lookup. + * + * The calculation of tbl->ideal_chain_maxlen below deserves some + * explanation. First, keep in mind that we're calculating the ideal + * maximum chain length based on the *new* (doubled) bucket count. + * In fractions this is just n/b (n=number of items,b=new num buckets). + * Since the ideal chain length is an integer, we want to calculate + * ceil(n/b). We don't depend on floating point arithmetic in this + * hash, so to calculate ceil(n/b) with integers we could write + * + * ceil(n/b) = (n/b) + ((n%b)?1:0) + * + * and in fact a previous version of this hash did just that. + * But now we have improved things a bit by recognizing that b is + * always a power of two. We keep its base 2 log handy (call it lb), + * so now we can write this with a bit shift and logical AND: + * + * ceil(n/b) = (n>>lb) + ( (n & (b-1)) ? 1:0) + * + */ +#define HASH_EXPAND_BUCKETS(tbl) \ +do { \ + unsigned _he_bkt; \ + unsigned _he_bkt_i; \ + struct UT_hash_handle *_he_thh, *_he_hh_nxt; \ + UT_hash_bucket *_he_new_buckets, *_he_newbkt; \ + _he_new_buckets = (UT_hash_bucket*)uthash_malloc( \ + 2UL * tbl->num_buckets * sizeof(struct UT_hash_bucket)); \ + if (!_he_new_buckets) { uthash_fatal( "out of memory"); } \ + memset(_he_new_buckets, 0, \ + 2UL * tbl->num_buckets * sizeof(struct UT_hash_bucket)); \ + tbl->ideal_chain_maxlen = \ + (tbl->num_items >> (tbl->log2_num_buckets+1U)) + \ + (((tbl->num_items & ((tbl->num_buckets*2U)-1U)) != 0U) ? 1U : 0U); \ + tbl->nonideal_items = 0; \ + for(_he_bkt_i = 0; _he_bkt_i < tbl->num_buckets; _he_bkt_i++) \ + { \ + _he_thh = tbl->buckets[ _he_bkt_i ].hh_head; \ + while (_he_thh != NULL) { \ + _he_hh_nxt = _he_thh->hh_next; \ + HASH_TO_BKT( _he_thh->hashv, tbl->num_buckets*2U, _he_bkt); \ + _he_newbkt = &(_he_new_buckets[ _he_bkt ]); \ + if (++(_he_newbkt->count) > tbl->ideal_chain_maxlen) { \ + tbl->nonideal_items++; \ + _he_newbkt->expand_mult = _he_newbkt->count / \ + tbl->ideal_chain_maxlen; \ + } \ + _he_thh->hh_prev = NULL; \ + _he_thh->hh_next = _he_newbkt->hh_head; \ + if (_he_newbkt->hh_head != NULL) { _he_newbkt->hh_head->hh_prev = \ + _he_thh; } \ + _he_newbkt->hh_head = _he_thh; \ + _he_thh = _he_hh_nxt; \ + } \ + } \ + uthash_free( tbl->buckets, tbl->num_buckets*sizeof(struct UT_hash_bucket) ); \ + tbl->num_buckets *= 2U; \ + tbl->log2_num_buckets++; \ + tbl->buckets = _he_new_buckets; \ + tbl->ineff_expands = (tbl->nonideal_items > (tbl->num_items >> 1)) ? \ + (tbl->ineff_expands+1U) : 0U; \ + if (tbl->ineff_expands > 1U) { \ + tbl->noexpand=1; \ + uthash_noexpand_fyi(tbl); \ + } \ + uthash_expand_fyi(tbl); \ +} while(0) + + +/* This is an adaptation of Simon Tatham's O(n log(n)) mergesort */ +/* Note that HASH_SORT assumes the hash handle name to be hh. + * HASH_SRT was added to allow the hash handle name to be passed in. */ +#define HASH_SORT(head,cmpfcn) HASH_SRT(hh,head,cmpfcn) +#define HASH_SRT(hh,head,cmpfcn) \ +do { \ + unsigned _hs_i; \ + unsigned _hs_looping,_hs_nmerges,_hs_insize,_hs_psize,_hs_qsize; \ + struct UT_hash_handle *_hs_p, *_hs_q, *_hs_e, *_hs_list, *_hs_tail; \ + if (head != NULL) { \ + _hs_insize = 1; \ + _hs_looping = 1; \ + _hs_list = &((head)->hh); \ + while (_hs_looping != 0U) { \ + _hs_p = _hs_list; \ + _hs_list = NULL; \ + _hs_tail = NULL; \ + _hs_nmerges = 0; \ + while (_hs_p != NULL) { \ + _hs_nmerges++; \ + _hs_q = _hs_p; \ + _hs_psize = 0; \ + for ( _hs_i = 0; _hs_i < _hs_insize; _hs_i++ ) { \ + _hs_psize++; \ + _hs_q = (UT_hash_handle*)((_hs_q->next != NULL) ? \ + ((void*)((char*)(_hs_q->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + if (! (_hs_q) ) { break; } \ + } \ + _hs_qsize = _hs_insize; \ + while ((_hs_psize > 0U) || ((_hs_qsize > 0U) && (_hs_q != NULL))) {\ + if (_hs_psize == 0U) { \ + _hs_e = _hs_q; \ + _hs_q = (UT_hash_handle*)((_hs_q->next != NULL) ? \ + ((void*)((char*)(_hs_q->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + _hs_qsize--; \ + } else if ( (_hs_qsize == 0U) || (_hs_q == NULL) ) { \ + _hs_e = _hs_p; \ + if (_hs_p != NULL){ \ + _hs_p = (UT_hash_handle*)((_hs_p->next != NULL) ? \ + ((void*)((char*)(_hs_p->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + } \ + _hs_psize--; \ + } else if (( \ + cmpfcn(DECLTYPE(head)(ELMT_FROM_HH((head)->hh.tbl,_hs_p)), \ + DECLTYPE(head)(ELMT_FROM_HH((head)->hh.tbl,_hs_q))) \ + ) <= 0) { \ + _hs_e = _hs_p; \ + if (_hs_p != NULL){ \ + _hs_p = (UT_hash_handle*)((_hs_p->next != NULL) ? \ + ((void*)((char*)(_hs_p->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + } \ + _hs_psize--; \ + } else { \ + _hs_e = _hs_q; \ + _hs_q = (UT_hash_handle*)((_hs_q->next != NULL) ? \ + ((void*)((char*)(_hs_q->next) + \ + (head)->hh.tbl->hho)) : NULL); \ + _hs_qsize--; \ + } \ + if ( _hs_tail != NULL ) { \ + _hs_tail->next = ((_hs_e != NULL) ? \ + ELMT_FROM_HH((head)->hh.tbl,_hs_e) : NULL); \ + } else { \ + _hs_list = _hs_e; \ + } \ + if (_hs_e != NULL) { \ + _hs_e->prev = ((_hs_tail != NULL) ? \ + ELMT_FROM_HH((head)->hh.tbl,_hs_tail) : NULL); \ + } \ + _hs_tail = _hs_e; \ + } \ + _hs_p = _hs_q; \ + } \ + if (_hs_tail != NULL){ \ + _hs_tail->next = NULL; \ + } \ + if ( _hs_nmerges <= 1U ) { \ + _hs_looping=0; \ + (head)->hh.tbl->tail = _hs_tail; \ + DECLTYPE_ASSIGN(head,ELMT_FROM_HH((head)->hh.tbl, _hs_list)); \ + } \ + _hs_insize *= 2U; \ + } \ + HASH_FSCK(hh,head); \ + } \ +} while (0) + +/* This function selects items from one hash into another hash. + * The end result is that the selected items have dual presence + * in both hashes. There is no copy of the items made; rather + * they are added into the new hash through a secondary hash + * hash handle that must be present in the structure. */ +#define HASH_SELECT(hh_dst, dst, hh_src, src, cond) \ +do { \ + unsigned _src_bkt, _dst_bkt; \ + void *_last_elt=NULL, *_elt; \ + UT_hash_handle *_src_hh, *_dst_hh, *_last_elt_hh=NULL; \ + ptrdiff_t _dst_hho = ((char*)(&(dst)->hh_dst) - (char*)(dst)); \ + if (src != NULL) { \ + for(_src_bkt=0; _src_bkt < (src)->hh_src.tbl->num_buckets; _src_bkt++) { \ + for(_src_hh = (src)->hh_src.tbl->buckets[_src_bkt].hh_head; \ + _src_hh != NULL; \ + _src_hh = _src_hh->hh_next) { \ + _elt = ELMT_FROM_HH((src)->hh_src.tbl, _src_hh); \ + if (cond(_elt)) { \ + _dst_hh = (UT_hash_handle*)(((char*)_elt) + _dst_hho); \ + _dst_hh->key = _src_hh->key; \ + _dst_hh->keylen = _src_hh->keylen; \ + _dst_hh->hashv = _src_hh->hashv; \ + _dst_hh->prev = _last_elt; \ + _dst_hh->next = NULL; \ + if (_last_elt_hh != NULL) { _last_elt_hh->next = _elt; } \ + if (dst == NULL) { \ + DECLTYPE_ASSIGN(dst,_elt); \ + HASH_MAKE_TABLE(hh_dst,dst); \ + } else { \ + _dst_hh->tbl = (dst)->hh_dst.tbl; \ + } \ + HASH_TO_BKT(_dst_hh->hashv, _dst_hh->tbl->num_buckets, _dst_bkt); \ + HASH_ADD_TO_BKT(_dst_hh->tbl->buckets[_dst_bkt],_dst_hh); \ + (dst)->hh_dst.tbl->num_items++; \ + _last_elt = _elt; \ + _last_elt_hh = _dst_hh; \ + } \ + } \ + } \ + } \ + HASH_FSCK(hh_dst,dst); \ +} while (0) + +#define HASH_CLEAR(hh,head) \ +do { \ + if (head != NULL) { \ + uthash_free((head)->hh.tbl->buckets, \ + (head)->hh.tbl->num_buckets*sizeof(struct UT_hash_bucket)); \ + HASH_BLOOM_FREE((head)->hh.tbl); \ + uthash_free((head)->hh.tbl, sizeof(UT_hash_table)); \ + (head)=NULL; \ + } \ +} while(0) + +#define HASH_OVERHEAD(hh,head) \ + ((head != NULL) ? ( \ + (size_t)(((head)->hh.tbl->num_items * sizeof(UT_hash_handle)) + \ + ((head)->hh.tbl->num_buckets * sizeof(UT_hash_bucket)) + \ + sizeof(UT_hash_table) + \ + (HASH_BLOOM_BYTELEN))) : 0U) + +#ifdef NO_DECLTYPE +#define HASH_ITER(hh,head,el,tmp) \ +for(((el)=(head)), ((*(char**)(&(tmp)))=(char*)((head!=NULL)?(head)->hh.next:NULL)); \ + (el) != NULL; ((el)=(tmp)), ((*(char**)(&(tmp)))=(char*)((tmp!=NULL)?(tmp)->hh.next:NULL))) +#else +#define HASH_ITER(hh,head,el,tmp) \ +for(((el)=(head)), ((tmp)=DECLTYPE(el)((head!=NULL)?(head)->hh.next:NULL)); \ + (el) != NULL; ((el)=(tmp)), ((tmp)=DECLTYPE(el)((tmp!=NULL)?(tmp)->hh.next:NULL))) +#endif + +/* obtain a count of items in the hash */ +#define HASH_COUNT(head) HASH_CNT(hh,head) +#define HASH_CNT(hh,head) ((head != NULL)?((head)->hh.tbl->num_items):0U) + +typedef struct UT_hash_bucket { + struct UT_hash_handle *hh_head; + unsigned count; + + /* expand_mult is normally set to 0. In this situation, the max chain length + * threshold is enforced at its default value, HASH_BKT_CAPACITY_THRESH. (If + * the bucket's chain exceeds this length, bucket expansion is triggered). + * However, setting expand_mult to a non-zero value delays bucket expansion + * (that would be triggered by additions to this particular bucket) + * until its chain length reaches a *multiple* of HASH_BKT_CAPACITY_THRESH. + * (The multiplier is simply expand_mult+1). The whole idea of this + * multiplier is to reduce bucket expansions, since they are expensive, in + * situations where we know that a particular bucket tends to be overused. + * It is better to let its chain length grow to a longer yet-still-bounded + * value, than to do an O(n) bucket expansion too often. + */ + unsigned expand_mult; + +} UT_hash_bucket; + +/* random signature used only to find hash tables in external analysis */ +#define HASH_SIGNATURE 0xa0111fe1u +#define HASH_BLOOM_SIGNATURE 0xb12220f2u + +typedef struct UT_hash_table { + UT_hash_bucket *buckets; + unsigned num_buckets, log2_num_buckets; + unsigned num_items; + struct UT_hash_handle *tail; /* tail hh in app order, for fast append */ + ptrdiff_t hho; /* hash handle offset (byte pos of hash handle in element */ + + /* in an ideal situation (all buckets used equally), no bucket would have + * more than ceil(#items/#buckets) items. that's the ideal chain length. */ + unsigned ideal_chain_maxlen; + + /* nonideal_items is the number of items in the hash whose chain position + * exceeds the ideal chain maxlen. these items pay the penalty for an uneven + * hash distribution; reaching them in a chain traversal takes >ideal steps */ + unsigned nonideal_items; + + /* ineffective expands occur when a bucket doubling was performed, but + * afterward, more than half the items in the hash had nonideal chain + * positions. If this happens on two consecutive expansions we inhibit any + * further expansion, as it's not helping; this happens when the hash + * function isn't a good fit for the key domain. When expansion is inhibited + * the hash will still work, albeit no longer in constant time. */ + unsigned ineff_expands, noexpand; + + uint32_t signature; /* used only to find hash tables in external analysis */ +#ifdef HASH_BLOOM + uint32_t bloom_sig; /* used only to test bloom exists in external analysis */ + uint8_t *bloom_bv; + uint8_t bloom_nbits; +#endif + +} UT_hash_table; + +typedef struct UT_hash_handle { + struct UT_hash_table *tbl; + void *prev; /* prev element in app order */ + void *next; /* next element in app order */ + struct UT_hash_handle *hh_prev; /* previous hh in bucket order */ + struct UT_hash_handle *hh_next; /* next hh in bucket order */ + void *key; /* ptr to enclosing struct's key */ + unsigned keylen; /* enclosing struct's key len */ + unsigned hashv; /* result of hash-fcn(key) */ +} UT_hash_handle; + +#endif /* UTHASH_H */
--- a/src/c/openssl.c Sun Dec 20 13:41:35 2015 -0500 +++ b/src/c/openssl.c Sun Dec 20 14:18:52 2015 -0500 @@ -79,7 +79,7 @@ if (access(uw_sig_file, F_OK)) { random_password(); - + if ((fd = open(uw_sig_file, O_WRONLY | O_CREAT, 0700)) < 0) { fprintf(stderr, "Can't open signature file %s\n", uw_sig_file); perror("open");
--- a/src/c/urweb.c Sun Dec 20 13:41:35 2015 -0500 +++ b/src/c/urweb.c Sun Dec 20 14:18:52 2015 -0500 @@ -22,6 +22,8 @@ #include "types.h" +#include "uthash.h" + uw_unit uw_unit_v = 0; @@ -70,6 +72,9 @@ void uw_buffer_reset(uw_buffer *b) { b->front = b->start; + if (b->front != b->back) { + *b->front = 0; + } } int uw_buffer_check(uw_buffer *b, size_t extra) { @@ -361,6 +366,9 @@ uw_global_custom(); uw_init_crypto(); + + // Fast non-cryptographic strength randomness for Sqlcache. + srandom(clock()); } void uw_app_init(uw_app *app) { @@ -419,6 +427,18 @@ void (*free)(void*); } global; +typedef struct uw_Sqlcache_Update { + uw_Sqlcache_Cache *cache; + char **keys; + uw_Sqlcache_Value *value; + struct uw_Sqlcache_Update *next; +} uw_Sqlcache_Update; + +typedef struct uw_Sqlcache_Unlock { + pthread_rwlock_t *lock; + struct uw_Sqlcache_Unlock *next; +} uw_Sqlcache_Unlock; + struct uw_context { uw_app *app; int id; @@ -483,6 +503,13 @@ char *output_buffer; size_t output_buffer_size; + // Sqlcache. + int numRecording, recordingCapacity; + int *recordingOffsets; + uw_Sqlcache_Update *cacheUpdate; + uw_Sqlcache_Update *cacheUpdateTail; + uw_Sqlcache_Unlock *cacheUnlock; + int remoteSock; }; @@ -567,8 +594,16 @@ ctx->output_buffer = malloc(1); ctx->output_buffer_size = 1; + ctx->numRecording = 0; + ctx->recordingCapacity = 0; + ctx->recordingOffsets = malloc(0); + ctx->cacheUpdate = NULL; + ctx->cacheUpdateTail = NULL; + ctx->remoteSock = -1; + ctx->cacheUnlock = NULL; + return ctx; } @@ -634,6 +669,8 @@ free(ctx->output_buffer); + free(ctx->recordingOffsets); + free(ctx); } @@ -657,6 +694,7 @@ ctx->usedSig = 0; ctx->needsResig = 0; ctx->remoteSock = -1; + ctx->numRecording = 0; } void uw_reset_keep_request(uw_context ctx) { @@ -1703,6 +1741,20 @@ *ctx->page.front = 0; } +void uw_recordingStart(uw_context ctx) { + if (ctx->numRecording == ctx->recordingCapacity) { + ++ctx->recordingCapacity; + ctx->recordingOffsets = realloc(ctx->recordingOffsets, sizeof(int) * ctx->recordingCapacity); + } + ctx->recordingOffsets[ctx->numRecording] = ctx->page.front - ctx->page.start; + ++ctx->numRecording; +} + +char *uw_recordingRead(uw_context ctx) { + char *recording = ctx->page.start + ctx->recordingOffsets[--ctx->numRecording]; + return strdup(recording); +} + char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) { char *result; int len; @@ -3633,7 +3685,7 @@ if (r == 0) { uw_ensure_transaction(ctx); ctx->app->initializer(ctx); - if (ctx->app->db_commit(ctx)) + if (uw_commit(ctx)) uw_error(ctx, FATAL, "Error running SQL COMMIT"); } @@ -4506,3 +4558,313 @@ void uw_set_remoteSock(uw_context ctx, int sock) { ctx->remoteSock = sock; } + + +// Sqlcache + +typedef struct uw_Sqlcache_Entry { + char *key; + uw_Sqlcache_Value *value; + unsigned long timeInvalid; + UT_hash_handle hh; +} uw_Sqlcache_Entry; + +static void uw_Sqlcache_freeValue(uw_Sqlcache_Value *value) { + if (value) { + free(value->result); + free(value->output); + free(value); + } +} + +static void uw_Sqlcache_freeEntry(uw_Sqlcache_Entry* entry) { + if (entry) { + free(entry->key); + uw_Sqlcache_freeValue(entry->value); + free(entry); + } +} + +// TODO: pick a number. +static unsigned int uw_Sqlcache_maxSize = 1234567890; + +static void uw_Sqlcache_delete(uw_Sqlcache_Cache *cache, uw_Sqlcache_Entry *entry) { + if (entry) { + HASH_DEL(cache->table, entry); + uw_Sqlcache_freeEntry(entry); + } +} + +static uw_Sqlcache_Entry *uw_Sqlcache_find(uw_Sqlcache_Cache *cache, char *key, size_t len, int bump) { + uw_Sqlcache_Entry *entry = NULL; + HASH_FIND(hh, cache->table, key, len, entry); + if (entry && bump) { + // Bump for LRU purposes. + HASH_DEL(cache->table, entry); + // Important that we use [entry->key], because [key] might be ephemeral. + HASH_ADD_KEYPTR(hh, cache->table, entry->key, len, entry); + } + return entry; +} + +static void uw_Sqlcache_add(uw_Sqlcache_Cache *cache, uw_Sqlcache_Entry *entry, size_t len) { + HASH_ADD_KEYPTR(hh, cache->table, entry->key, len, entry); + if (HASH_COUNT(cache->table) > uw_Sqlcache_maxSize) { + // Deletes the first element of the cache. + uw_Sqlcache_delete(cache, cache->table); + } +} + +static unsigned long uw_Sqlcache_getTimeNow(uw_Sqlcache_Cache *cache) { + // TODO: verify that this makes time comparisons do the Right Thing. + return cache->timeNow++; +} + +static unsigned long uw_Sqlcache_timeMax(unsigned long x, unsigned long y) { + return x > y ? x : y; +} + +static char uw_Sqlcache_keySep = '_'; + +static char *uw_Sqlcache_allocKeyBuffer(char **keys, size_t numKeys) { + size_t len = 0; + while (numKeys-- > 0) { + char* k = keys[numKeys]; + if (!k) { + // Can only happen when flushing, in which case we don't need anything past the null key. + break; + } + // Leave room for separator. + len += 1 + strlen(k); + } + char *buf = malloc(len+1); + // If nothing is copied into the buffer, it should look like it has length 0. + buf[0] = 0; + return buf; +} + +static char *uw_Sqlcache_keyCopy(char *buf, char *key) { + *buf++ = uw_Sqlcache_keySep; + return stpcpy(buf, key); +} + +// The NUL-terminated prefix of [key] below always looks something like "_k1_k2_k3..._kn". + +uw_Sqlcache_Value *uw_Sqlcache_check(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys) { + int doBump = random() % 1024 == 0; + if (doBump) { + pthread_rwlock_wrlock(&cache->lockIn); + } else { + pthread_rwlock_rdlock(&cache->lockIn); + } + size_t numKeys = cache->numKeys; + char *key = uw_Sqlcache_allocKeyBuffer(keys, numKeys); + char *buf = key; + time_t timeInvalid = cache->timeInvalid; + uw_Sqlcache_Entry *entry; + if (numKeys == 0) { + entry = cache->table; + if (!entry) { + free(key); + pthread_rwlock_unlock(&cache->lockIn); + return NULL; + } + } else { + while (numKeys-- > 0) { + buf = uw_Sqlcache_keyCopy(buf, keys[numKeys]); + size_t len = buf - key; + entry = uw_Sqlcache_find(cache, key, len, doBump); + if (!entry) { + free(key); + pthread_rwlock_unlock(&cache->lockIn); + return NULL; + } + timeInvalid = uw_Sqlcache_timeMax(timeInvalid, entry->timeInvalid); + } + free(key); + } + uw_Sqlcache_Value *value = entry->value; + pthread_rwlock_unlock(&cache->lockIn); + // ASK: though the argument isn't trivial, this is safe, right? + // Returning outside the lock is safe because updates happen at commit time. + // Those are the only times the returned value or its strings can get freed. + // Handler output is a new string, so it's safe to free this at commit time. + return value && timeInvalid < value->timeValid ? value : NULL; +} + +static void uw_Sqlcache_storeCommitOne(uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcache_Value *value) { + pthread_rwlock_wrlock(&cache->lockIn); + size_t numKeys = cache->numKeys; + time_t timeNow = uw_Sqlcache_getTimeNow(cache); + uw_Sqlcache_Entry *entry; + if (numKeys == 0) { + entry = cache->table; + if (!entry) { + entry = calloc(1, sizeof(uw_Sqlcache_Entry)); + entry->key = NULL; + entry->value = NULL; + entry->timeInvalid = 0; + cache->table = entry; + } + } else { + char *key = uw_Sqlcache_allocKeyBuffer(keys, numKeys); + char *buf = key; + while (numKeys-- > 0) { + buf = uw_Sqlcache_keyCopy(buf, keys[numKeys]); + size_t len = buf - key; + + entry = uw_Sqlcache_find(cache, key, len, 1); + if (!entry) { + entry = calloc(1, sizeof(uw_Sqlcache_Entry)); + entry->key = strdup(key); + entry->value = NULL; + entry->timeInvalid = 0; + uw_Sqlcache_add(cache, entry, len); + } + } + free(key); + } + if (!entry->value || entry->value->timeValid < value->timeValid) { + uw_Sqlcache_freeValue(entry->value); + entry->value = value; + entry->value->timeValid = timeNow; + } + pthread_rwlock_unlock(&cache->lockIn); +} + +static void uw_Sqlcache_flushCommitOne(uw_Sqlcache_Cache *cache, char **keys) { +} + +static void uw_Sqlcache_commit(void *data) { + uw_context ctx = (uw_context)data; + uw_Sqlcache_Update *update = ctx->cacheUpdate; + while (update) { + uw_Sqlcache_Cache *cache = update->cache; + char **keys = update->keys; + if (update->value) { + uw_Sqlcache_storeCommitOne(cache, keys, update->value); + } else { + uw_Sqlcache_flushCommitOne(cache, keys); + } + update = update->next; + } +} + +static void uw_Sqlcache_free(void *data, int dontCare) { + uw_context ctx = (uw_context)data; + uw_Sqlcache_Update *update = ctx->cacheUpdate; + while (update) { + char** keys = update->keys; + size_t numKeys = update->cache->numKeys; + while (numKeys-- > 0) { + free(keys[numKeys]); + } + free(keys); + // Don't free [update->value]: it's in the cache now! + uw_Sqlcache_Update *nextUpdate = update->next; + free(update); + update = nextUpdate; + } + ctx->cacheUpdate = NULL; + ctx->cacheUpdateTail = NULL; + uw_Sqlcache_Unlock *unlock = ctx->cacheUnlock; + while (unlock) { + pthread_rwlock_unlock(unlock->lock); + uw_Sqlcache_Unlock *nextUnlock = unlock->next; + free(unlock); + unlock = nextUnlock; + } + ctx->cacheUnlock = NULL; +} + +static void uw_Sqlcache_pushUnlock(uw_context ctx, pthread_rwlock_t *lock) { + if (!ctx->cacheUnlock) { + // Just need one registered commit for both updating and unlocking. + uw_register_transactional(ctx, ctx, uw_Sqlcache_commit, NULL, uw_Sqlcache_free); + } + uw_Sqlcache_Unlock *unlock = malloc(sizeof(uw_Sqlcache_Unlock)); + unlock->lock = lock; + unlock->next = ctx->cacheUnlock; + ctx->cacheUnlock = unlock; +} + +void uw_Sqlcache_rlock(uw_context ctx, uw_Sqlcache_Cache *cache) { + pthread_rwlock_rdlock(&cache->lockOut); + uw_Sqlcache_pushUnlock(ctx, &cache->lockOut); +} + +void uw_Sqlcache_wlock(uw_context ctx, uw_Sqlcache_Cache *cache) { + pthread_rwlock_wrlock(&cache->lockOut); + uw_Sqlcache_pushUnlock(ctx, &cache->lockOut); +} + +static char **uw_Sqlcache_copyKeys(char **keys, size_t numKeys) { + char **copy = malloc(sizeof(char *) * numKeys); + while (numKeys-- > 0) { + char *k = keys[numKeys]; + copy[numKeys] = k ? strdup(k) : NULL; + } + return copy; +} + +void uw_Sqlcache_store(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcache_Value *value) { + uw_Sqlcache_Update *update = malloc(sizeof(uw_Sqlcache_Update)); + update->cache = cache; + update->keys = uw_Sqlcache_copyKeys(keys, cache->numKeys); + update->value = value; + update->next = NULL; + // Can't use [uw_Sqlcache_getTimeNow] because it modifies state and we don't have the lock. + pthread_rwlock_rdlock(&cache->lockIn); + value->timeValid = cache->timeNow; + pthread_rwlock_unlock(&cache->lockIn); + if (ctx->cacheUpdateTail) { + ctx->cacheUpdateTail->next = update; + } else { + ctx->cacheUpdate = update; + } + ctx->cacheUpdateTail = update; +} + +void uw_Sqlcache_flush(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys) { + // A flush has to happen immediately so that subsequent stores in the same transaction fail. + // This is safe to do because we will always call [uw_Sqlcache_wlock] earlier. + // If the transaction fails, the only harm done is a few extra cache misses. + pthread_rwlock_wrlock(&cache->lockIn); + size_t numKeys = cache->numKeys; + if (numKeys == 0) { + uw_Sqlcache_Entry *entry = cache->table; + if (entry) { + uw_Sqlcache_freeValue(entry->value); + entry->value = NULL; + } + } else { + char *key = uw_Sqlcache_allocKeyBuffer(keys, numKeys); + char *buf = key; + time_t timeNow = uw_Sqlcache_getTimeNow(cache); + while (numKeys-- > 0) { + char *k = keys[numKeys]; + if (!k) { + size_t len = buf - key; + if (len == 0) { + // The first key was null. + cache->timeInvalid = timeNow; + } else { + uw_Sqlcache_Entry *entry = uw_Sqlcache_find(cache, key, len, 0); + if (entry) { + entry->timeInvalid = timeNow; + } + } + free(key); + pthread_rwlock_unlock(&cache->lockIn); + return; + } + buf = uw_Sqlcache_keyCopy(buf, k); + } + // All the keys were non-null, so we delete the pointed-to entry. + size_t len = buf - key; + uw_Sqlcache_Entry *entry = uw_Sqlcache_find(cache, key, len, 0); + free(key); + uw_Sqlcache_delete(cache, entry); + } + pthread_rwlock_unlock(&cache->lockIn); +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/cache.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,17 @@ +structure Cache = struct + +type cache = + {(* Takes a query ID and parameters (and, for store, the value to + store) and gives an FFI call that checks, stores, or flushes the + relevant entry. The parameters are strings for check and store and + optional strings for flush because some parameters might not be + fixed. *) + check : int * Mono.exp list -> Mono.exp', + store : int * Mono.exp list * Mono.exp -> Mono.exp', + flush : int * Mono.exp list -> Mono.exp', + lock : int * bool (* true = write, false = read *) -> Mono.exp', + (* Generates C needed for FFI calls in check, store, and flush. *) + setupGlobal : Print.PD.pp_desc, + setupQuery : {index : int, params : int} -> Print.PD.pp_desc} + +end
--- a/src/cjr_print.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/cjr_print.sml Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -734,7 +734,7 @@ string (Int.toString (size has_arg)), string ", ((*request)[0] == '/' ? ++*request : NULL), ", newline, - + if unboxable then unurlify' "(*request)" (#1 t) else @@ -914,7 +914,7 @@ space, string "4, ((*request)[0] == '/' ? ++*request : NULL), ", newline, - + string "({", newline, p_typ env (t, loc), @@ -1188,7 +1188,7 @@ string "(ctx,", space, string "it", - string (Int.toString level), + string (Int.toString level), string ");", newline] else @@ -1388,7 +1388,7 @@ string (Int.toString level), string ");", newline]) - + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function"; space) in @@ -1578,7 +1578,7 @@ newline], string "tmp;", newline, - string "})"] + string "})"] end | ENone _ => string "NULL" | ESome (t, e) => @@ -2078,7 +2078,7 @@ space, p_exp' false false (E.pushERel (E.pushERel env "r" (TRecord rnum, loc)) - "acc" state) + "acc" state) body, string ";", newline] @@ -2102,7 +2102,7 @@ newline, string "uw_ensure_transaction(ctx);", newline, - + case prepared of NONE => box [string "char *query = ", @@ -2187,7 +2187,7 @@ string "uw_ensure_transaction(ctx);", newline, newline, - + #dmlPrepared (Settings.currentDbms ()) {loc = loc, id = id, dml = dml', @@ -3396,6 +3396,13 @@ newline, newline, + (* For sqlcache. *) + let + val {setupGlobal, setupQuery, ...} = Sqlcache.getCache () + in + box (setupGlobal :: newline :: List.map setupQuery (Sqlcache.getFfiInfo ())) + end, + newline, p_list_sep newline (fn x => x) pds, newline, @@ -3451,7 +3458,7 @@ makeChecker ("uw_check_envVar", Settings.getEnvVarRules ()), newline, - + string "extern void uw_sign(const char *in, char *out);", newline, string "extern int uw_hash_blocksize;", @@ -3498,7 +3505,7 @@ newline, string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"), newline, - string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), + string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), newline, string "uw_write(ctx, jslib);", newline, @@ -3523,7 +3530,7 @@ newline, string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"), newline, - string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), + string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), newline, string "uw_replace_page(ctx, \"", string (hexify (#Bytes r)),
--- a/src/cjrize.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/cjrize.sml Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -586,7 +586,7 @@ let val (vis, sm) = ListUtil.foldlMap (fn ((x, n, t, e, _), sm) => - let + let val (t, sm) = cifyTyp (t, sm) fun unravel (tAll as (t, _), eAll as (e, _)) = @@ -601,7 +601,7 @@ (ErrorMsg.errorAt loc "Function isn't explicit at code generation"; ([], tAll, eAll)) | _ => ([], tAll, eAll) - + val (args, ran, e) = unravel (t, e) val (e, sm) = cifyExp (e, sm) in @@ -610,7 +610,7 @@ sm vis in (SOME (L'.DFunRec vis, loc), NONE, sm) - end + end | L.DExport (ek, s, n, ts, t, b) => let
--- a/src/compiler.sig Sun Dec 20 13:41:35 2015 -0500 +++ b/src/compiler.sig Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -122,6 +122,7 @@ val pathcheck : (Mono.file, Mono.file) phase val sidecheck : (Mono.file, Mono.file) phase val sigcheck : (Mono.file, Mono.file) phase + val sqlcache : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase val checknest : (Cjr.file, Cjr.file) phase @@ -137,12 +138,12 @@ val toCorify : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform - val toEspecialize1' : (string, Core.file) transform + val toEspecialize1' : (string, Core.file) transform val toShake1' : (string, Core.file) transform val toRpcify : (string, Core.file) transform val toCore_untangle2 : (string, Core.file) transform val toShake2 : (string, Core.file) transform - val toEspecialize1 : (string, Core.file) transform + val toEspecialize1 : (string, Core.file) transform val toCore_untangle3 : (string, Core.file) transform val toShake3 : (string, Core.file) transform val toTag : (string, Core.file) transform @@ -187,6 +188,7 @@ val toPathcheck : (string, Mono.file) transform val toSidecheck : (string, Mono.file) transform val toSigcheck : (string, Mono.file) transform + val toSqlcache : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform val toChecknest : (string, Cjr.file) transform
--- a/src/compiler.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/compiler.sml Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -structure Compiler :> COMPILER = struct +structure Compiler :> COMPILER = struct structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token) structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens) @@ -268,7 +268,7 @@ | _ => absyn end handle LrParser.ParseError => [], - print = SourcePrint.p_file} + print = SourcePrint.p_file} fun p_job ({prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers, scripts, @@ -1094,7 +1094,7 @@ ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.") else (); - + makeD true "" pieces before ignore (foldl (fn (new, path) => let @@ -1449,12 +1449,22 @@ val toSigcheck = transform sigcheck "sigcheck" o toSidecheck +val sqlcache = { + func = (fn file => + if Settings.getSqlcache () + then let val file = MonoInline.inlineFull file in Sqlcache.go file end + else file), + print = MonoPrint.p_file MonoEnv.empty +} + +val toSqlcache = transform sqlcache "sqlcache" o toSigcheck + val cjrize = { func = Cjrize.cjrize, print = CjrPrint.p_file CjrEnv.empty } -val toCjrize = transform cjrize "cjrize" o toSigcheck +val toCjrize = transform cjrize "cjrize" o toSqlcache val prepare = { func = Prepare.prepare, @@ -1610,7 +1620,7 @@ compileC {cname = cname, oname = oname, ename = ename, libs = libs, profile = #profile job, debug = #debug job, linker = #linker job, link = #link job} - + before cleanup ()) end handle ex => (((cleanup ()) handle _ => ()); raise ex)
--- a/src/iflow.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/iflow.sml Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -115,36 +115,36 @@ | PCon1 s => box [string (s ^ "("), p_list p_exp es, string ")"] - | Eq => p_bop "=" es - | Ne => p_bop "<>" es - | Lt => p_bop "<" es - | Le => p_bop "<=" es - | Gt => p_bop ">" es - | Ge => p_bop ">=" es + | Cmp Eq => p_bop "=" es + | Cmp Ne => p_bop "<>" es + | Cmp Lt => p_bop "<" es + | Cmp Le => p_bop "<=" es + | Cmp Gt => p_bop ">" es + | Cmp Ge => p_bop ">=" es fun p_prop p = case p of True => string "True" | False => string "False" | Unknown => string "??" - | And (p1, p2) => box [string "(", - p_prop p1, - string ")", - space, - string "&&", - space, - string "(", - p_prop p2, - string ")"] - | Or (p1, p2) => box [string "(", - p_prop p1, - string ")", - space, - string "||", - space, - string "(", - p_prop p2, - string ")"] + | Lop (And, p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "&&", + space, + string "(", + p_prop p2, + string ")"] + | Lop (Or, p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "||", + space, + string "(", + p_prop p2, + string ")"] | Reln (r, es) => p_reln r es | Cond (e, p) => box [string "(", p_exp e, @@ -518,7 +518,7 @@ Variety = Nothing, Known = ref (!(#Known (unNode r))), Ge = ref NONE}) - + val r'' = ref (Node {Id = nodeId (), Rep = ref NONE, Cons = #Cons (unNode r), @@ -529,7 +529,7 @@ #Rep (unNode r) := SOME r''; r' end - | _ => raise Contradiction + | _ => raise Contradiction end in rep e @@ -687,9 +687,9 @@ end | _ => raise Contradiction end - | (Eq, [e1, e2]) => + | (Cmp Eq, [e1, e2]) => markEq (representative (db, e1), representative (db, e2)) - | (Ge, [e1, e2]) => + | (Cmp Ge, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) @@ -734,14 +734,14 @@ (case #Variety (unNode (representative (db, e))) of Dt1 (f', _) => f' = f | _ => false) - | (Eq, [e1, e2]) => + | (Cmp Eq, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) in repOf r1 = repOf r2 end - | (Ge, [e1, e2]) => + | (Cmp Ge, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) @@ -848,7 +848,7 @@ (hyps := (n', hs, ref false); Cc.clear db; app (fn a => Cc.assert (db, a)) hs) - end + end fun useKeys () = let @@ -872,7 +872,7 @@ let val r = Cc.check (db, - AReln (Eq, [Proj (r1, f), + AReln (Cmp Eq, [Proj (r1, f), Proj (r2, f)])) in (*Print.prefaces "Fs" @@ -888,7 +888,7 @@ r end)) ks then (changed := true; - Cc.assert (db, AReln (Eq, [r1, r2])); + Cc.assert (db, AReln (Cmp Eq, [r1, r2])); finder (hyps, acc)) else finder (hyps, a :: acc) @@ -1115,7 +1115,7 @@ val (_, hs, _) = !hyps in hnames := n + 1; - hyps := (n, List.filter (fn AReln (Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) + hyps := (n, List.filter (fn AReln (Cmp Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) end fun check a = Cc.check (db, a) @@ -1138,7 +1138,7 @@ val ls = removeDups ls in if List.exists (fn x' => x' = x) ls then - ls + ls else x :: ls end @@ -1171,7 +1171,7 @@ | Null => inl (Func (DtCon0 "None", [])) | SqNot e => inr (case expIn e of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) | inr _ => Unknown) | Field (v, f) => inl (Proj (rvOf v, f)) | Computed _ => default () @@ -1181,15 +1181,15 @@ val e2 = expIn e2 in inr (case (bo, e1, e2) of - (Exps f, inl e1, inl e2) => f (e1, e2) - | (Props f, v1, v2) => + (RCmp c, inl e1, inl e2) => Reln (Cmp c, [e1, e2]) + | (RLop l, v1, v2) => let fun pin v = case v of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) | inr p => p in - f (pin v1, pin v2) + Lop (l, pin v1, pin v2) end | _ => Unknown) end @@ -1205,7 +1205,7 @@ (case expIn e of inl e => inl (Func (Other f, [e])) | _ => default ()) - + | Unmodeled => inl (Func (Other "allow", [rv ()])) end in @@ -1219,8 +1219,8 @@ True => (k () handle Cc.Contradiction => ()) | False => () | Unknown => () - | And (p1, p2) => go p1 (fn () => go p2 k) - | Or (p1, p2) => + | Lop (And, p1, p2) => go p1 (fn () => go p2 k) + | Lop (Or, p1, p2) => let val saved = save () in @@ -1263,7 +1263,7 @@ val new = ref NONE val old = ref NONE - val rvs = map (fn (tab, v) => + val rvs = map (fn Table (tab, v) => let val nv = #NextVar arg () in @@ -1272,7 +1272,8 @@ | "Old" => old := SOME (tab, nv) | _ => (); (v, nv) - end) (#From r) + end + | _ => raise Fail "Iflow: not ready for joins or nesteds") (#From r) fun rvOf v = case List.find (fn (v', _) => v' = v) rvs of @@ -1282,7 +1283,8 @@ val expIn = expIn (#NextVar arg) (#Env arg) rvOf val saved = #Save arg () - fun addFrom () = app (fn (t, v) => #Add arg (AReln (Sql t, [rvOf v]))) (#From r) + fun addFrom () = app (fn Table (t, v) => #Add arg (AReln (Sql t, [rvOf v])) + | _ => raise Fail "Iflow: not ready for joins or nesteds") (#From r) fun usedFields e = case e of @@ -1351,7 +1353,7 @@ | SOME e => let val p = case expIn e of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) | inr p => p val saved = #Save arg () @@ -1365,9 +1367,9 @@ fun normal () = doWhere normal' in (case #Select r of - [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => - (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of - Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => + [SqExp (Binop (RCmp bo, Count, SqConst (Prim.Int 0)), f)] => + (case bo of + Gt => (case #Cont arg of SomeCol _ => () | AllCols k => @@ -1469,7 +1471,7 @@ evalExp env e (fn e => doArgs (es, e :: acc)) in doArgs (es, []) - end + end in case #1 e of EPrim p => k (Const p) @@ -1519,7 +1521,7 @@ ([], []) => (evalExp env' (#body rf) (fn _ => ()); St.reinstate saved; default ()) - + | (arg :: args, mode :: modes) => evalExp env arg (fn arg => let @@ -1663,7 +1665,7 @@ Save = St.stash, Restore = St.reinstate, Cont = AllCols (fn x => - (St.assert [AReln (Eq, [r, x])]; + (St.assert [AReln (Cmp Eq, [r, x])]; evalExp (acc :: r :: env) b k))} q end) | EDml (e, _) => @@ -1697,15 +1699,15 @@ | Delete (tab, e) => let val old = St.nextVar () - + val expIn = expIn (Var o St.nextVar) env (fn "T" => Var old | _ => raise Fail "Iflow.evalExp: Bad field expression in DELETE") val p = case expIn e of - inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean" + inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean" | inr p => p - + val saved = St.stash () in St.assert [AReln (Sql (tab ^ "$Old"), [Var old]), @@ -1748,7 +1750,7 @@ (f, Proj (Var old, f)) :: fs) fs fs' val p = case expIn e of - inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean" + inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean" | inr p => p val saved = St.stash () in @@ -1764,7 +1766,7 @@ k (Recd [])) handle Cc.Contradiction => ()) end) - + | ENextval (EPrim (Prim.String (_, seq)), _) => let val nv = St.nextVar () @@ -1780,7 +1782,7 @@ val e = Var (St.nextVar ()) val e' = Func (Other ("cookie/" ^ cname), []) in - St.assert [AReln (Known, [e]), AReln (Eq, [e, e'])]; + St.assert [AReln (Known, [e]), AReln (Cmp Eq, [e, e'])]; k e end @@ -2159,7 +2161,7 @@ end | _ => ()) end - + | _ => () in app decl (#1 file)
--- a/src/jscomp.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/jscomp.sml Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -195,7 +195,7 @@ str loc "}"])], {disc = t, result = s}), loc) val body = (EAbs ("x", t, s, body), loc) - + val st = {decls = ("jsify", n', (TFun (t, s), loc), body, "jsify") :: #decls st, script = #script st, @@ -575,7 +575,7 @@ val e = String.translate (fn #"'" => "\\'" | #"\\" => "\\\\" | ch => String.str ch) e - + val sc = "urfuncs[" ^ Int.toString n ^ "] = {c:\"t\",f:'" ^ e ^ "'};\n" in @@ -801,7 +801,7 @@ | _ => default () in seek (e', [x]) - end + end | ECase (e', pes, _) => let @@ -1032,7 +1032,7 @@ | ERel _ => (e, st) | ENamed _ => (e, st) | ECon (_, _, NONE) => (e, st) - | ECon (dk, pc, SOME e) => + | ECon (dk, pc, SOME e) => let val (e, st) = exp outer (e, st) in @@ -1084,7 +1084,7 @@ in ((EBinop (bi, s, e1, e2), loc), st) end - + | ERecord xets => let val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) => @@ -1259,7 +1259,7 @@ in ((ESignalSource e, loc), st) end - + | EServerCall (e1, t, ef, fm) => let val (e1, st) = exp outer (e1, st)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/list_key_fn.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,14 @@ +functor ListKeyFn(K : ORD_KEY) + : ORD_KEY where type ord_key = K.ord_key list = struct + +type ord_key = K.ord_key list + +val rec compare = + fn ([], []) => EQUAL + | ([], _) => LESS + | (_, []) => GREATER + | (x::xs, y::ys) => case K.compare (x, y) of + EQUAL => compare (xs, ys) + | ord => ord + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/lru_cache.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,203 @@ +structure LruCache : sig + val cache : Cache.cache +end = struct + + +(* Mono *) + +open Mono + +val dummyLoc = ErrorMsg.dummySpan +val stringTyp = (TFfi ("Basis", "string"), dummyLoc) +val optionStringTyp = (TOption stringTyp, dummyLoc) +fun withTyp typ = map (fn exp => (exp, typ)) + +fun ffiAppCache' (func, index, argTyps) = + EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps) + +fun check (index, keys) = + ffiAppCache' ("check", index, withTyp stringTyp keys) + +fun store (index, keys, value) = + ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys) + +fun flush (index, keys) = + ffiAppCache' ("flush", index, withTyp optionStringTyp keys) + +fun lock (index, write) = + ffiAppCache' ((if write then "w" else "r") ^ "lock", index, []) + + +(* Cjr *) + +open Print +open Print.PD + +fun setupQuery {index, params} = + let + + val i = Int.toString index + + fun paramRepeat itemi sep = + let + fun f n = + if n < 0 then "" + else if n = 0 then itemi (Int.toString 0) + else f (n-1) ^ sep ^ itemi (Int.toString n) + in + f (params - 1) + end + + fun paramRepeatRev itemi sep = + let + fun f n = + if n < 0 then "" + else if n = 0 then itemi (Int.toString 0) + else itemi (Int.toString n) ^ sep ^ f (n-1) + in + f (params - 1) + end + + fun paramRepeatInit itemi sep = + if params = 0 then "" else sep ^ paramRepeat itemi sep + + val typedArgs = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", " + + val revArgs = paramRepeatRev (fn p => "p" ^ p) ", " + + val argNums = List.tabulate (params, fn i => "p" ^ Int.toString i) + in + Print.box + [string ("static uw_Sqlcache_Cache cacheStruct" ^ i ^ " = {"), + newline, + string " .lockIn = PTHREAD_RWLOCK_INITIALIZER,", + newline, + string " .lockOut = PTHREAD_RWLOCK_INITIALIZER,", + newline, + string " .table = NULL,", + newline, + string (" .numKeys = " ^ Int.toString params ^ ","), + newline, + string " .timeInvalid = 0,", + newline, + string " .timeNow = 0};", + newline, + string ("static uw_Sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"), + newline, + newline, + + string ("static void uw_Sqlcache_rlock" ^ i ^ "(uw_context ctx) {"), + newline, + string (" uw_Sqlcache_rlock(ctx, cache" ^ i ^ ");"), + newline, + string "}", + newline, + newline, + + string ("static void uw_Sqlcache_wlock" ^ i ^ "(uw_context ctx) {"), + newline, + string (" uw_Sqlcache_wlock(ctx, cache" ^ i ^ ");"), + newline, + string "}", + newline, + newline, + + string ("static uw_Basis_string uw_Sqlcache_check" ^ i), + string ("(uw_context ctx" ^ typedArgs ^ ") {"), + newline, + string (" char *ks[] = {" ^ revArgs ^ "};"), + newline, + string (" uw_Sqlcache_Value *v = uw_Sqlcache_check(ctx, cache" ^ i ^ ", ks);"), + newline, + (* If the output is null, it means we had too much recursion, so it's a miss. *) + string " if (v && v->output != NULL) {", + newline, + (*string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"), + newline,*) + string " uw_write(ctx, v->output);", + newline, + string " return v->result;", + newline, + string " } else {", + newline, + (*string (" printf(\"SQLCACHE: miss " ^ i ^ " " ^ String.concatWith ", " (List.tabulate (params, fn _ => "%s")) ^ ".\\n\""), + (case argNums of + [] => Print.box [] + | _ => Print.box [string ", ", + p_list string argNums]), + string ");", + newline,*) + string " uw_recordingStart(ctx);", + newline, + string " return NULL;", + newline, + string " }", + newline, + string "}", + newline, + newline, + + string ("static uw_unit uw_Sqlcache_store" ^ i), + string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"), + newline, + string (" char *ks[] = {" ^ revArgs ^ "};"), + newline, + string (" uw_Sqlcache_Value *v = malloc(sizeof(uw_Sqlcache_Value));"), + newline, + string " v->result = strdup(s);", + newline, + string " v->output = uw_recordingRead(ctx);", + newline, + (*string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"), + newline,*) + string (" uw_Sqlcache_store(ctx, cache" ^ i ^ ", ks, v);"), + newline, + string " return uw_unit_v;", + newline, + string "}", + newline, + newline, + + string ("static uw_unit uw_Sqlcache_flush" ^ i), + string ("(uw_context ctx" ^ typedArgs ^ ") {"), + newline, + string (" char *ks[] = {" ^ revArgs ^ "};"), + newline, + string (" uw_Sqlcache_flush(ctx, cache" ^ i ^ ", ks);"), + newline, + (*string (" puts(\"SQLCACHE: flushed " ^ i ^ ".\");"), + newline,*) + string " return uw_unit_v;", + newline, + string "}", + newline, + newline] + end + +val setupGlobal = string "/* No global setup for LRU cache. */" + + +(* Bundled up. *) + +(* For now, use the toy implementation if there are no arguments. *) +fun toyIfNoKeys numKeys implLru implToy args = + if numKeys args = 0 + then implToy args + else implLru args + +val cache = + (* let *) + (* val {check = toyCheck, *) + (* store = toyStore, *) + (* flush = toyFlush, *) + (* setupQuery = toySetupQuery, *) + (* ...} = ToyCache.cache *) + (* in *) + (* {check = toyIfNoKeys (length o #2) check toyCheck, *) + (* store = toyIfNoKeys (length o #2) store toyStore, *) + (* flush = toyIfNoKeys (length o #2) flush toyFlush, *) + {check = check, store = store, flush = flush, lock = lock, + setupQuery = setupQuery, setupGlobal = setupGlobal} + (* end *) + +end
--- a/src/main.mlton.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/main.mlton.sml Sun Dec 20 14:18:52 2015 -0500 @@ -159,6 +159,12 @@ | "-iflow" :: rest => (Compiler.doIflow := true; doArgs rest) + | "-sqlcache" :: rest => + (Settings.setSqlcache true; + doArgs rest) + | "-heuristic" :: h :: rest => + (Sqlcache.setHeuristic h; + doArgs rest) | "-moduleOf" :: fname :: _ => (print (Compiler.moduleOf fname ^ "\n"); raise Code OS.Process.success)
--- a/src/mono.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/mono.sml Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -119,7 +119,7 @@ | ESignalReturn of exp | ESignalBind of exp * exp | ESignalSource of exp - + | EServerCall of exp * typ * effect * failure_mode | ERecv of exp * typ | ESleep of exp
--- a/src/mono_env.sig Sun Dec 20 13:41:35 2015 -0500 +++ b/src/mono_env.sig Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
--- a/src/mono_env.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/mono_env.sml Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mono_fooify.sig Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,39 @@ +signature MONO_FOOIFY = sig + +(* TODO: don't expose raw references if possible. *) +val nextPvar : int ref +val pvarDefs : ((string * int * (string * int * Mono.typ option) list) list) ref + +datatype foo_kind = Attr | Url + +structure Fm : sig + type t + + type vr = string * int * Mono.typ * Mono.exp * string + + val empty : int -> t + + val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int + val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int + val enter : t -> t + (* This list should be reversed before adding to list of file declarations. *) + val decls : t -> Mono.decl list + + val freshName : t -> int * t +end + +(* General form used in [Monoize]. *) +val fooifyExp : foo_kind + -> (int -> Mono.typ * string) + -> (int -> string * (string * int * Mono.typ option) list) + -> Fm.t + -> Mono.exp * Mono.typ + -> Mono.exp * Fm.t + +(* Easy-to-use interface in [Sqlcache]. Uses [Fm.canonical]. *) +val canonicalFm : Fm.t ref (* Set at the end of [Monoize]. *) +val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp option +(* This list should be reversed before adding to list of file declarations. *) +val getNewFmDecls : unit -> Mono.decl list + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mono_fooify.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,346 @@ +structure MonoFooify :> MONO_FOOIFY = struct + +open Mono + +datatype foo_kind = + Attr + | Url + +val nextPvar = ref 0 +val pvarDefs = ref ([] : (string * int * (string * int * typ option) list) list) + +structure Fm = struct + +type vr = string * int * typ * exp * string + +structure IM = IntBinaryMap + +structure M = BinaryMapFn(struct + type ord_key = foo_kind + fun compare x = + case x of + (Attr, Attr) => EQUAL + | (Attr, _) => LESS + | (_, Attr) => GREATER + + | (Url, Url) => EQUAL + end) + +structure TM = BinaryMapFn(struct + type ord_key = typ + val compare = MonoUtil.Typ.compare + end) + +type t = { + count : int, + map : int IM.map M.map, + listMap : int TM.map M.map, + decls : vr list +} + +fun empty count = { + count = count, + map = M.empty, + listMap = M.empty, + decls = [] +} + +fun chooseNext count = + let + val n = !nextPvar + in + if count < n then + (count, count+1) + else + (nextPvar := n + 1; + (n, n+1)) + end + +fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []} +fun freshName {count, map, listMap, decls} = + let + val (next, count) = chooseNext count + in + (next, {count = count , map = map, listMap = listMap, decls = decls}) + end +fun decls ({decls, ...} : t) = + case decls of + [] => [] + | _ => [(DValRec decls, ErrorMsg.dummySpan)] + +fun lookup (t as {count, map, listMap, decls}) k n thunk = + let + val im = Option.getOpt (M.find (map, k), IM.empty) + in + case IM.find (im, n) of + NONE => + let + val n' = count + val (d, {count, map, listMap, decls}) = + thunk count {count = count + 1, + map = M.insert (map, k, IM.insert (im, n, n')), + listMap = listMap, + decls = decls} + in + ({count = count, + map = map, + listMap = listMap, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +fun lookupList (t as {count, map, listMap, decls}) k tp thunk = + let + val tm = Option.getOpt (M.find (listMap, k), TM.empty) + in + case TM.find (tm, tp) of + NONE => + let + val n' = count + val (d, {count, map, listMap, decls}) = + thunk count {count = count + 1, + map = map, + listMap = M.insert (listMap, k, TM.insert (tm, tp, n')), + decls = decls} + in + ({count = count, + map = map, + listMap = listMap, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +end + +fun fk2s fk = + case fk of + Attr => "attr" + | Url => "url" + +fun capitalize s = + if s = "" then + s + else + str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +structure E = ErrorMsg + +exception TypeMismatch of Fm.t * E.span +exception CantPass of Fm.t * typ +exception DontKnow of Fm.t * typ + +val dummyExp = (EPrim (Prim.Int 0), E.dummySpan) + +fun fooifyExpWithExceptions fk lookupENamed lookupDatatype = + let + fun fooify fm (e, tAll as (t, loc)) = + case #1 e of + EClosure (fnam, [(ERecord [], _)]) => + let + val (_, s) = lookupENamed fnam + in + ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) + end + | EClosure (fnam, args) => + let + val (ft, s) = lookupENamed fnam + fun attrify (args, ft, e, fm) = + case (args, ft) of + ([], _) => (e, fm) + | (arg :: args, (TFun (t, ft), _)) => + let + val (arg', fm) = fooify fm (arg, t) + in + attrify (args, ft, + (EStrcat (e, + (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), + arg'), loc)), loc), + fm) + end + | _ => raise TypeMismatch (fm, loc) + in + attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) + end + | _ => + case t of + TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + | TFfi (m, x) => (if Settings.mayClientToServer (m, x) + then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) + else raise CantPass (fm, tAll)) + + | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + | TRecord ((x, t) :: xts) => + let + val (se, fm) = fooify fm ((EField (e, x), loc), t) + in + foldl (fn ((x, t), (se, fm)) => + let + val (se', fm) = fooify fm ((EField (e, x), loc), t) + in + ((EStrcat (se, + (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), + se'), loc)), loc), + fm) + end) (se, fm) xts + end + + | TDatatype (i, ref (dk, _)) => + let + fun makeDecl n fm = + let + val (x, xncs) = + case ListUtil.search (fn (x, i', xncs) => + if i' = i then + SOME (x, xncs) + else + NONE) (!pvarDefs) of + NONE => lookupDatatype i + | SOME v => v + + val (branches, fm) = + ListUtil.foldlMap + (fn ((x, n, to), fm) => + case to of + NONE => + (((PCon (dk, PConVar n, NONE), loc), + (EPrim (Prim.String (Prim.Normal, x)), loc)), + fm) + | SOME t => + let + val (arg, fm) = fooify fm ((ERel 0, loc), t) + in + (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc), + arg), loc)), + fm) + end) + fm xncs + + val dom = tAll + val ran = (TFfi ("Basis", "string"), loc) + in + ((fk2s fk ^ "ify_" ^ x, + n, + (TFun (dom, ran), loc), + (EAbs ("x", + dom, + ran, + (ECase ((ERel 0, loc), + branches, + {disc = dom, + result = ran}), loc)), loc), + ""), + fm) + end + + val (fm, n) = Fm.lookup fm fk i makeDecl + in + ((EApp ((ENamed n, loc), e), loc), fm) + end + + | TOption t => + let + val (body, fm) = fooify fm ((ERel 0, loc), t) + in + ((ECase (e, + [((PNone t, loc), + (EPrim (Prim.String (Prim.Normal, "None")), loc)), + + ((PSome (t, (PVar ("x", t), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc), + body), loc))], + {disc = tAll, + result = (TFfi ("Basis", "string"), loc)}), loc), + fm) + end + + | TList t => + let + fun makeDecl n fm = + let + val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc) + val (arg, fm) = fooify fm ((ERel 0, loc), rt) + + val branches = [((PNone rt, loc), + (EPrim (Prim.String (Prim.Normal, "Nil")), loc)), + ((PSome (rt, (PVar ("a", rt), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc), + arg), loc))] + + val dom = tAll + val ran = (TFfi ("Basis", "string"), loc) + in + ((fk2s fk ^ "ify_list", + n, + (TFun (dom, ran), loc), + (EAbs ("x", + dom, + ran, + (ECase ((ERel 0, loc), + branches, + {disc = dom, + result = ran}), loc)), loc), + ""), + fm) + end + + val (fm, n) = Fm.lookupList fm fk t makeDecl + in + ((EApp ((ENamed n, loc), e), loc), fm) + end + + | _ => raise DontKnow (fm, tAll) + in + fooify + end + +fun fooifyExp fk lookupENamed lookupDatatype fm exp = + fooifyExpWithExceptions fk lookupENamed lookupDatatype fm exp + handle TypeMismatch (fm, loc) => + (E.errorAt loc "Type mismatch encoding attribute"; + (dummyExp, fm)) + | CantPass (fm, typ as (_, loc)) => + (E.errorAt loc "MonoFooify: can't pass type from client to server"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)]; + (dummyExp, fm)) + | DontKnow (fm, typ as (_, loc)) => + (E.errorAt loc "Don't know how to encode attribute/URL type"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)]; + (dummyExp, fm)) + +(* Has to be set at the end of [Monoize]. *) +val canonicalFm = ref (Fm.empty 0 : Fm.t) + +fun urlify env expTyp = + let + val (exp, fm) = + fooifyExpWithExceptions + Url + (fn n => + let + val (_, t, _, s) = MonoEnv.lookupENamed env n + in + (t, s) + end) + (fn n => MonoEnv.lookupDatatype env n) + (!canonicalFm) + expTyp + in + canonicalFm := fm; + SOME exp + end + handle TypeMismatch _ => NONE + | CantPass _ => NONE + | DontKnow _ => NONE + +fun getNewFmDecls () = + let + val fm = !canonicalFm + in + canonicalFm := Fm.enter fm; + Fm.decls fm + end + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mono_inline.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,28 @@ +structure MonoInline = struct + +fun inlineFull file = + let + val oldInline = Settings.getMonoInline () + val oldFull = !MonoReduce.fullMode + in + (Settings.setMonoInline (case Int.maxInt of + NONE => 1000000 + | SOME n => n); + MonoReduce.fullMode := true; + let + val file = MonoReduce.reduce file + val file = MonoOpt.optimize file + val file = Fuse.fuse file + val file = MonoOpt.optimize file + val file = MonoShake.shake file + in + file + end before + (MonoReduce.fullMode := oldFull; + Settings.setMonoInline oldInline)) + handle ex => (Settings.setMonoInline oldInline; + MonoReduce.fullMode := oldFull; + raise ex) + end + +end
--- a/src/mono_opt.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/mono_opt.sml Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -169,7 +169,7 @@ | EStrcat (e1, (EPrim (Prim.String (_, "")), _)) => #1 e1 | EStrcat ((EPrim (Prim.String (_, "")), _), e2) => #1 e2 - + | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) => let val s = @@ -182,7 +182,7 @@ in EPrim (Prim.String (Prim.Html, s)) end - + | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EPrim (Prim.String (_, s2)), _)) => EPrim (Prim.String (Prim.Normal, s1 ^ s2)) @@ -540,7 +540,7 @@ else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => + | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -568,7 +568,7 @@ EPrim (Prim.String (Prim.Normal, s)) end - | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => + | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -593,7 +593,7 @@ EPrim (Prim.String (Prim.Normal, s)) end - | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => + | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => EPrim (Prim.String (Prim.Normal, unAs s)) | EFfiApp ("Basis", "unAs", [(e', _)]) => let
--- a/src/mono_print.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/mono_print.sml Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -391,7 +391,7 @@ string "__", string (Int.toString n)] else - string x + string x in box [xp, space, @@ -541,7 +541,7 @@ space, p_policy env p] | DOnError _ => string "ONERROR" - + fun p_file env (file, _) = let val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
--- a/src/mono_util.sig Sun Dec 20 13:41:35 2015 -0500 +++ b/src/mono_util.sig Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -68,7 +68,7 @@ val fold : {typ : Mono.typ' * 'state -> 'state, exp : Mono.exp' * 'state -> 'state} -> 'state -> Mono.exp -> 'state - + val exists : {typ : Mono.typ' -> bool, exp : Mono.exp' -> bool} -> Mono.exp -> bool
--- a/src/mono_util.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/mono_util.sml Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -281,7 +281,7 @@ S.map2 (mft t, fn t' => (ERedirect (e', t'), loc))) - + | EStrcat (e1, e2) => S.bind2 (mfe ctx e1, fn e1' => @@ -334,6 +334,7 @@ RelE ("acc", dummyt))) body, fn body' => + (* ASK: is this the right thing to do? *) S.map2 (mfe ctx initial, fn initial' => (EQuery {exps = exps', @@ -624,7 +625,7 @@ (x, n, t', e', s))) in mfd - end + end fun mapfold {typ = fc, exp = fe, decl = fd} = mapfoldB {typ = fc,
--- a/src/monoize.sig Sun Dec 20 13:41:35 2015 -0500 +++ b/src/monoize.sig Sun Dec 20 14:18:52 2015 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
--- a/src/monoize.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/monoize.sml Sun Dec 20 14:18:52 2015 -0500 @@ -50,9 +50,9 @@ (L'.TRecord r2, E.dummySpan)) end) -val nextPvar = ref 0 +val nextPvar = MonoFooify.nextPvar val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) -val pvarDefs = ref ([] : (string * int * (string * int * L'.typ option) list) list) +val pvarDefs = MonoFooify.pvarDefs val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list) fun choosePvar () = @@ -374,311 +374,26 @@ val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) -structure IM = IntBinaryMap - -datatype foo_kind = - Attr - | Url - -fun fk2s fk = - case fk of - Attr => "attr" - | Url => "url" - -type vr = string * int * L'.typ * L'.exp * string - -structure Fm :> sig - type t - - val empty : int -> t - - val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int - val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> vr * t) -> t * int - val enter : t -> t - val decls : t -> L'.decl list - - val freshName : t -> int * t -end = struct - -structure M = BinaryMapFn(struct - type ord_key = foo_kind - fun compare x = - case x of - (Attr, Attr) => EQUAL - | (Attr, _) => LESS - | (_, Attr) => GREATER - - | (Url, Url) => EQUAL - end) - -structure TM = BinaryMapFn(struct - type ord_key = L'.typ - val compare = MonoUtil.Typ.compare - end) - -type t = { - count : int, - map : int IM.map M.map, - listMap : int TM.map M.map, - decls : vr list -} - -fun empty count = { - count = count, - map = M.empty, - listMap = M.empty, - decls = [] -} - -fun chooseNext count = - let - val n = !nextPvar - in - if count < n then - (count, count+1) - else - (nextPvar := n + 1; - (n, n+1)) - end - -fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []} -fun freshName {count, map, listMap, decls} = - let - val (next, count) = chooseNext count - in - (next, {count = count , map = map, listMap = listMap, decls = decls}) - end -fun decls ({decls, ...} : t) = - case decls of - [] => [] - | _ => [(L'.DValRec decls, ErrorMsg.dummySpan)] - -fun lookup (t as {count, map, listMap, decls}) k n thunk = - let - val im = Option.getOpt (M.find (map, k), IM.empty) - in - case IM.find (im, n) of - NONE => +structure Fm = MonoFooify.Fm + +fun fooifyExp fk env = + MonoFooify.fooifyExp + fk + (fn n => let - val n' = count - val (d, {count, map, listMap, decls}) = - thunk count {count = count + 1, - map = M.insert (map, k, IM.insert (im, n, n')), - listMap = listMap, - decls = decls} + val (_, t, _, s) = Env.lookupENamed env n in - ({count = count, - map = map, - listMap = listMap, - decls = d :: decls}, n') - end - | SOME n' => (t, n') - end - -fun lookupList (t as {count, map, listMap, decls}) k tp thunk = - let - val tm = Option.getOpt (M.find (listMap, k), TM.empty) - in - case TM.find (tm, tp) of - NONE => + (monoType env t, s) + end) + (fn n => let - val n' = count - val (d, {count, map, listMap, decls}) = - thunk count {count = count + 1, - map = map, - listMap = M.insert (listMap, k, TM.insert (tm, tp, n')), - decls = decls} + val (x, _, xncs) = Env.lookupDatatype env n in - ({count = count, - map = map, - listMap = listMap, - decls = d :: decls}, n') - end - | SOME n' => (t, n') - end - -end - - -fun capitalize s = - if s = "" then - s - else - str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) - -fun fooifyExp fk env = - let - fun fooify fm (e, tAll as (t, loc)) = - case #1 e of - L'.EClosure (fnam, [(L'.ERecord [], _)]) => - let - val (_, _, _, s) = Env.lookupENamed env fnam - in - ((L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) - end - | L'.EClosure (fnam, args) => - let - val (_, ft, _, s) = Env.lookupENamed env fnam - val ft = monoType env ft - - fun attrify (args, ft, e, fm) = - case (args, ft) of - ([], _) => (e, fm) - | (arg :: args, (L'.TFun (t, ft), _)) => - let - val (arg', fm) = fooify fm (arg, t) - in - attrify (args, ft, - (L'.EStrcat (e, - (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc), - arg'), loc)), loc), - fm) - end - | _ => (E.errorAt loc "Type mismatch encoding attribute"; - (e, fm)) - in - attrify (args, ft, (L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) - end - | _ => - case t of - L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm) - | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) - - | L'.TRecord [] => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm) - | L'.TRecord ((x, t) :: xts) => - let - val (se, fm) = fooify fm ((L'.EField (e, x), loc), t) - in - foldl (fn ((x, t), (se, fm)) => - let - val (se', fm) = fooify fm ((L'.EField (e, x), loc), t) - in - ((L'.EStrcat (se, - (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc), - se'), loc)), loc), - fm) - end) (se, fm) xts - end - - | L'.TDatatype (i, ref (dk, _)) => - let - fun makeDecl n fm = - let - val (x, xncs) = - case ListUtil.search (fn (x, i', xncs) => - if i' = i then - SOME (x, xncs) - else - NONE) (!pvarDefs) of - NONE => - let - val (x, _, xncs) = Env.lookupDatatype env i - in - (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs) - end - | SOME v => v - - val (branches, fm) = - ListUtil.foldlMap - (fn ((x, n, to), fm) => - case to of - NONE => - (((L'.PCon (dk, L'.PConVar n, NONE), loc), - (L'.EPrim (Prim.String (Prim.Normal, x)), loc)), - fm) - | SOME t => - let - val (arg, fm) = fooify fm ((L'.ERel 0, loc), t) - in - (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, x ^ "/")), loc), - arg), loc)), - fm) - end) - fm xncs - - val dom = tAll - val ran = (L'.TFfi ("Basis", "string"), loc) - in - ((fk2s fk ^ "ify_" ^ x, - n, - (L'.TFun (dom, ran), loc), - (L'.EAbs ("x", - dom, - ran, - (L'.ECase ((L'.ERel 0, loc), - branches, - {disc = dom, - result = ran}), loc)), loc), - ""), - fm) - end - - val (fm, n) = Fm.lookup fm fk i makeDecl - in - ((L'.EApp ((L'.ENamed n, loc), e), loc), fm) - end - - | L'.TOption t => - let - val (body, fm) = fooify fm ((L'.ERel 0, loc), t) - in - ((L'.ECase (e, - [((L'.PNone t, loc), - (L'.EPrim (Prim.String (Prim.Normal, "None")), loc)), - - ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Some/")), loc), - body), loc))], - {disc = tAll, - result = (L'.TFfi ("Basis", "string"), loc)}), loc), - fm) - end - - | L'.TList t => - let - fun makeDecl n fm = - let - val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc) - val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt) - - val branches = [((L'.PNone rt, loc), - (L'.EPrim (Prim.String (Prim.Normal, "Nil")), loc)), - ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Cons/")), loc), - arg), loc))] - - val dom = tAll - val ran = (L'.TFfi ("Basis", "string"), loc) - in - ((fk2s fk ^ "ify_list", - n, - (L'.TFun (dom, ran), loc), - (L'.EAbs ("x", - dom, - ran, - (L'.ECase ((L'.ERel 0, loc), - branches, - {disc = dom, - result = ran}), loc)), loc), - ""), - fm) - end - - val (fm, n) = Fm.lookupList fm fk t makeDecl - in - ((L'.EApp ((L'.ENamed n, loc), e), loc), fm) - end - - | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; - Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; - (dummyExp, fm)) - in - fooify - end - -val attrifyExp = fooifyExp Attr -val urlifyExp = fooifyExp Url + (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs) + end) + +val attrifyExp = fooifyExp MonoFooify.Attr +val urlifyExp = fooifyExp MonoFooify.Url datatype 'a failable_search = Found of 'a @@ -1962,7 +1677,6 @@ (L'.ERel 1, loc)), loc), (L'.ERel 0, loc)), loc), (L'.ERecord [], loc)), loc) - val body = (L'.EQuery {exps = exps, tables = tables, state = state, @@ -4653,12 +4367,14 @@ val (nullable, notNullable) = calcClientish xts fun cond (x, v) = - (L'.EStrcat (str (Settings.mangleSql x - ^ (case v of - Client => "" - | Channel => " >> 32") - ^ " = "), - target), loc) + (L'.EStrcat ((L'.EStrcat (str ("((" + ^ Settings.mangleSql x + ^ (case v of + Client => "" + | Channel => " >> 32") + ^ ") = "), + target), loc), + str ")"), loc) val e = foldl (fn ((x, v), e) => @@ -4678,16 +4394,19 @@ [] => e | eb :: ebs => (L'.ESeq ( - (L'.EDml (foldl - (fn (eb, s) => - (L'.EStrcat (s, - (L'.EStrcat (str " OR ", - cond eb), loc)), loc)) - (L'.EStrcat (str ("DELETE FROM " - ^ Settings.mangleSql tab - ^ " WHERE "), - cond eb), loc) - ebs, L'.Error), loc), + (L'.EDml ((L'.EStrcat (str ("DELETE FROM " + ^ Settings.mangleSql tab + ^ " WHERE "), + foldl (fn (eb, s) => + (L'.EStrcat (str "(", + (L'.EStrcat (s, + (L'.EStrcat (str " OR ", + (L'.EStrcat (cond eb, + str ")"), + loc)), loc)), loc)), loc)) + (cond eb) + ebs), loc), + L'.Error), loc), e), loc) in e @@ -4750,7 +4469,7 @@ val mname = CoreUtil.File.maxName file + 1 val () = nextPvar := mname - val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => + val (_, fm, ds) = List.foldl (fn (d, (env, fm, ds)) => case #1 d of L.DDatabase s => let @@ -4793,12 +4512,14 @@ (L'.DDatatype (dts @ !pvarDefs), loc) :: Fm.decls fm @ ds | _ => ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds))) - (env, Fm.empty mname, []) file + (env, Fm.empty mname, []) file + val monoFile = (rev ds, []) in pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - (rev ds, []) + MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile + 1); + monoFile end end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/multimap_fn.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,16 @@ +functor MultimapFn (structure KeyMap : ORD_MAP structure ValSet : ORD_SET) = struct + type key = KeyMap.Key.ord_key + type item = ValSet.item + type itemSet = ValSet.set + type multimap = ValSet.set KeyMap.map + val empty : multimap = KeyMap.empty + fun insertSet (kToVs : multimap, k : key, vs : itemSet) : multimap = + KeyMap.unionWith ValSet.union (kToVs, KeyMap.singleton (k, vs)) + fun insert (kToVs : multimap, k : key, v : item) : multimap = + insertSet (kToVs, k, ValSet.singleton v) + fun findSet (kToVs : multimap, k : key) = + case KeyMap.find (kToVs, k) of + SOME vs => vs + | NONE => ValSet.empty + val findList : multimap * key -> item list = ValSet.listItems o findSet +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/option_key_fn.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,12 @@ +functor OptionKeyFn(K : ORD_KEY) + : ORD_KEY where type ord_key = K.ord_key option = struct + +type ord_key = K.ord_key option + +val compare = + fn (NONE, NONE) => EQUAL + | (NONE, _) => LESS + | (_, NONE) => GREATER + | (SOME x, SOME y) => K.compare (x, y) + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/pair_key_fn.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,12 @@ +functor PairKeyFn (structure I : ORD_KEY + structure J : ORD_KEY) + : ORD_KEY where type ord_key = I.ord_key * J.ord_key = struct + +type ord_key = I.ord_key * J.ord_key + +fun compare ((i1, j1), (i2, j2)) = + case I.compare (i1, i2) of + EQUAL => J.compare (j1, j2) + | ord => ord + +end
--- a/src/settings.sig Sun Dec 20 13:41:35 2015 -0500 +++ b/src/settings.sig Sun Dec 20 14:18:52 2015 -0500 @@ -283,6 +283,9 @@ val setLessSafeFfi : bool -> unit val getLessSafeFfi : unit -> bool + val setSqlcache : bool -> unit + val getSqlcache : unit -> bool + val setFilePath : string -> unit (* Sets the directory where we look for files being added below. *)
--- a/src/settings.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/settings.sml Sun Dec 20 14:18:52 2015 -0500 @@ -151,7 +151,8 @@ val effectful = ref effectfulBase fun setEffectful ls = effectful := S.addList (effectfulBase, ls) -fun isEffectful x = S.member (!effectful, x) +fun isEffectful ("Sqlcache", _) = true + | isEffectful x = S.member (!effectful, x) fun addEffectful x = effectful := S.add (!effectful, x) val benignBase = basis ["get_cookie", @@ -801,6 +802,10 @@ fun setLessSafeFfi b = less := b fun getLessSafeFfi () = !less +val sqlcache = ref false +fun setSqlcache b = sqlcache := b +fun getSqlcache () = !sqlcache + structure SM = BinaryMapFn(struct type ord_key = string val compare = String.compare
--- a/src/sources Sun Dec 20 13:41:35 2015 -0500 +++ b/src/sources Sun Dec 20 14:18:52 2015 -0500 @@ -168,6 +168,27 @@ $(SRC)/mono_print.sig $(SRC)/mono_print.sml +$(SRC)/mono_fooify.sig +$(SRC)/mono_fooify.sml + +$(SRC)/sql.sig +$(SRC)/sql.sml + +$(SRC)/union_find_fn.sml +$(SRC)/multimap_fn.sml + +$(SRC)/list_key_fn.sml +$(SRC)/option_key_fn.sml +$(SRC)/pair_key_fn.sml +$(SRC)/triple_key_fn.sml + +$(SRC)/cache.sml +$(SRC)/toy_cache.sml +$(SRC)/lru_cache.sml + +$(SRC)/sqlcache.sig +$(SRC)/sqlcache.sml + $(SRC)/monoize.sig $(SRC)/monoize.sml @@ -186,8 +207,6 @@ $(SRC)/fuse.sig $(SRC)/fuse.sml -$(SRC)/sql.sml - $(SRC)/iflow.sig $(SRC)/iflow.sml @@ -206,6 +225,8 @@ $(SRC)/sigcheck.sig $(SRC)/sigcheck.sml +$(SRC)/mono_inline.sml + $(SRC)/cjr.sml $(SRC)/postgres.sig
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sql.sig Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,104 @@ +signature SQL = sig + +val debug : bool ref + +val sqlcacheMode : bool ref + +datatype chunk = + String of string + | Exp of Mono.exp + +val chunkify : Mono.exp -> chunk list + +type lvar = int + +datatype func = + DtCon0 of string + | DtCon1 of string + | UnCon of string + | Other of string + +datatype exp = + Const of Prim.t + | Var of int + | Lvar of lvar + | Func of func * exp list + | Recd of (string * exp) list + | Proj of exp * string + +datatype cmp = + Eq + | Ne + | Lt + | Le + | Gt + | Ge + +datatype reln = + Known + | Sql of string + | PCon0 of string + | PCon1 of string + | Cmp of cmp + +datatype lop = + And + | Or + +datatype prop = + True + | False + | Unknown + | Lop of lop * prop * prop + | Reln of reln * exp list + | Cond of exp * prop + +type 'a parser + +val parse : 'a parser -> Mono.exp -> 'a option + +datatype Rel = + RCmp of cmp + | RLop of lop + +datatype sqexp = + SqConst of Prim.t + | SqTrue + | SqFalse + | SqNot of sqexp + | Field of string * string + | Computed of string + | Binop of Rel * sqexp * sqexp + | SqKnown of sqexp + | Inj of Mono.exp + | SqFunc of string * sqexp + | Unmodeled + | Null + +datatype ('a,'b) sum = inl of 'a | inr of 'b + +datatype sitem = + SqField of string * string + | SqExp of sqexp * string + +datatype jtype = Inner | Left | Right | Full + +datatype fitem = + Table of string * string (* table AS name *) + | Join of jtype * fitem * fitem * sqexp + | Nested of query * string (* query AS name *) + + and query = + Query1 of {Select : sitem list, From : fitem list, Where : sqexp option} + | Union of query * query + +val query : query parser + +datatype dml = + Insert of string * (string * sqexp) list + | Delete of string * sqexp + | Update of string * (string * sqexp) list * sqexp + +val dml : dml parser + +end
--- a/src/sql.sml Sun Dec 20 13:41:35 2015 -0500 +++ b/src/sql.sml Sun Dec 20 14:18:52 2015 -0500 @@ -1,4 +1,4 @@ -structure Sql = struct +structure Sql :> SQL = struct open Mono @@ -20,24 +20,30 @@ | Recd of (string * exp) list | Proj of exp * string -datatype reln = - Known - | Sql of string - | PCon0 of string - | PCon1 of string - | Eq +datatype cmp = + Eq | Ne | Lt | Le | Gt | Ge +datatype reln = + Known + | Sql of string + | PCon0 of string + | PCon1 of string + | Cmp of cmp + +datatype lop = + And + | Or + datatype prop = True | False | Unknown - | And of prop * prop - | Or of prop * prop + | Lop of lop * prop * prop | Reln of reln * exp list | Cond of exp * prop @@ -146,6 +152,18 @@ end | _ => NONE +(* Used by primSqlcache. *) +fun optConst s chs = + case chs of + String s' :: chs => if String.isPrefix s s' then + SOME (s, if size s = size s' then + chs + else + String (String.extract (s', size s, NONE)) :: chs) + else + SOME ("", String s' :: chs) + | _ => NONE + fun ws p = wrap (follow (skip (fn ch => ch = #" ")) (follow p (skip (fn ch => ch = #" ")))) (#1 o #2) @@ -177,14 +195,14 @@ else NONE) -val field = wrap (follow t_ident - (follow (const ".") - uw_ident)) - (fn (t, ((), f)) => (t, f)) +val field = wrap (follow (opt (follow t_ident (const "."))) + uw_ident) + (fn (SOME (t, ()), f) => (t, f) + | (NONE, f) => ("T", f)) (* Should probably deal with this MySQL/SQLite case better some day. *) datatype Rel = - Exps of exp * exp -> prop - | Props of prop * prop -> prop + RCmp of cmp + | RLop of lop datatype sqexp = SqConst of Prim.t @@ -200,7 +218,7 @@ | Unmodeled | Null -fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2]))) +fun cmp s r = wrap (const s) (fn () => RCmp r) val sqbrel = altL [cmp "=" Eq, cmp "<>" Ne, @@ -208,8 +226,8 @@ cmp "<" Lt, cmp ">=" Ge, cmp ">" Gt, - wrap (const "AND") (fn () => Props And), - wrap (const "OR") (fn () => Props Or)] + wrap (const "AND") (fn () => RLop And), + wrap (const "OR") (fn () => RLop Or)] datatype ('a, 'b) sum = inl of 'a | inr of 'b @@ -238,7 +256,7 @@ end else NONE - | _ => NONE + | _ => NONE val prim = altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit))) @@ -250,6 +268,23 @@ wrap (follow (opt (const "E")) (follow string (opt (const "::text")))) ((fn s => Prim.String (Prim.Normal, s)) o #1 o #2)] +val primSqlcache = + (* Like [prim], but always uses [Prim.String]s. *) + let + fun wrapS p f = wrap p ((fn s => Prim.String (Prim.Normal, s)) o f) + in + altL [wrapS (follow (wrap (follow (keep Char.isDigit) + (follow (const ".") (keep Char.isDigit))) + (fn (x, ((), y)) => x ^ "." ^ y)) + (optConst "::float8")) + op^, + wrapS (follow (keep Char.isDigit) + (optConst "::int8")) + op^, + wrapS (follow (optConst "E") (follow string (optConst "::text"))) + (fn (c1, (s, c2)) => c1 ^ s ^ c2)] +end + fun known' chs = case chs of Exp (EFfi ("Basis", "sql_known"), _) :: chs => SOME ((), chs) @@ -267,9 +302,15 @@ ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs => SOME (e, chs) - + | _ => NONE +(* For sqlcache, we only care that we can do string equality on injected Mono + expressions, so accept any expression without modifying it. *) +val sqlifySqlcache = + fn Exp e :: chs => SOME (e, chs) + | _ => NONE + fun constK s = wrap (const s) (fn () => s) val funcName = altL [constK "COUNT", @@ -278,12 +319,19 @@ constK "SUM", constK "AVG"] +fun arithmetic pExp = follow (const "(") + (follow pExp + (follow (altL (map const [" + ", " - ", " * ", " / ", " >> ", " << "])) + (follow pExp (const ")")))) + val unmodeled = altL [const "COUNT(*)", const "CURRENT_TIMESTAMP"] +val sqlcacheMode = ref false; + fun sqexp chs = log "sqexp" - (altL [wrap prim SqConst, + (altL [wrap (if !sqlcacheMode then primSqlcache else prim) SqConst, wrap (const "TRUE") (fn () => SqTrue), wrap (const "FALSE") (fn () => SqFalse), wrap (const "NULL") (fn () => Null), @@ -291,8 +339,9 @@ wrap uw_ident Computed, wrap known SqKnown, wrap func SqFunc, + wrap (arithmetic sqexp) (fn _ => Unmodeled), wrap unmodeled (fn () => Unmodeled), - wrap sqlify Inj, + wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj, wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",") (follow (keep (fn ch => ch <> #")")) (const ")"))))) (fn ((), (e, _)) => e), @@ -317,7 +366,7 @@ and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")")))) (fn ((), ((), (e, ()))) => e) chs - + and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")")))) (fn (f, ((), (e, ()))) => (f, e)) chs @@ -333,48 +382,71 @@ (wrap (follow (const "SELECT ") (list sitem)) (fn ((), ls) => ls)) -val fitem = wrap (follow uw_ident - (follow (const " AS ") - t_ident)) - (fn (t, ((), f)) => (t, f)) +datatype jtype = Inner | Left | Right | Full -val from = log "from" - (wrap (follow (const "FROM ") (list fitem)) - (fn ((), ls) => ls)) +datatype fitem = + Table of string * string (* table AS name *) + | Join of jtype * fitem * fitem * sqexp + | Nested of query * string (* query AS name *) + + and query = + Query1 of {Select : sitem list, From : fitem list, Where : sqexp option} + | Union of query * query val wher = wrap (follow (ws (const "WHERE ")) sqexp) (fn ((), ls) => ls) -type query1 = {Select : sitem list, - From : (string * string) list, - Where : sqexp option} - -val query1 = log "query1" - (wrap (follow (follow select from) (opt wher)) - (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) - -datatype query = - Query1 of query1 - | Union of query * query - val orderby = log "orderby" (wrap (follow (ws (const "ORDER BY ")) - (follow (list sqexp) - (opt (ws (const "DESC"))))) + (list (follow sqexp + (opt (ws (const "DESC")))))) ignore) -fun query chs = log "query" - (wrap - (follow - (alt (wrap (follow (const "((") - (follow query - (follow (const ") UNION (") - (follow query (const "))"))))) - (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) - (wrap query1 Query1)) - (opt orderby)) - #1) - chs +val jtype = altL [wrap (const "JOIN") (fn () => Inner), + wrap (const "LEFT JOIN") (fn () => Left), + wrap (const "RIGHT JOIN") (fn () => Right), + wrap (const "FULL JOIN") (fn () => Full)] + +fun fitem chs = altL [wrap (follow uw_ident + (follow (const " AS ") + t_ident)) + (fn (t, ((), f)) => Table (t, f)), + wrap (follow (const "(") + (follow fitem + (follow (ws jtype) + (follow fitem + (follow (const " ON ") + (follow sqexp + (const ")"))))))) + (fn ((), (fi1, (jt, (fi2, ((), (se, ())))))) => + Join (jt, fi1, fi2, se)), + wrap (follow (const "(") + (follow query + (follow (const ") AS ") t_ident))) + (fn ((), (q, ((), f))) => Nested (q, f))] + chs + +and query1 chs = log "query1" + (wrap (follow (follow select from) (opt wher)) + (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) + chs + +and from chs = log "from" + (wrap (follow (const "FROM ") (list fitem)) + (fn ((), ls) => ls)) + chs + +and query chs = log "query" + (wrap (follow + (alt (wrap (follow (const "((") + (follow query + (follow (const ") UNION (") + (follow query (const "))"))))) + (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) + (wrap query1 Query1)) + (opt orderby)) + #1) + chs datatype dml = Insert of string * (string * sqexp) list @@ -396,22 +468,24 @@ val delete = log "delete" (wrap (follow (const "DELETE FROM ") (follow uw_ident - (follow (const " AS T_T WHERE ") - sqexp))) - (fn ((), (tab, ((), es))) => (tab, es))) + (follow (opt (const " AS T_T")) + (opt (follow (const " WHERE ") sqexp))))) + (fn ((), (tab, (_, wher))) => (tab, case wher of + SOME (_, es) => es + | NONE => SqTrue))) val setting = log "setting" - (wrap (follow uw_ident (follow (const " = ") sqexp)) - (fn (f, ((), e)) => (f, e))) + (wrap (follow uw_ident (follow (const " = ") sqexp)) + (fn (f, ((), e)) => (f, e))) val update = log "update" (wrap (follow (const "UPDATE ") (follow uw_ident - (follow (const " AS T_T SET ") + (follow (follow (opt (const " AS T_T")) (const " SET ")) (follow (list setting) (follow (ws (const "WHERE ")) sqexp))))) - (fn ((), (tab, ((), (fs, ((), e))))) => + (fn ((), (tab, (_, (fs, ((), e))))) => (tab, fs, e))) val dml = log "dml"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sqlcache.sig Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,11 @@ +signature SQLCACHE = sig + +val setCache : Cache.cache -> unit +val getCache : unit -> Cache.cache + +val setHeuristic : string -> unit + +val getFfiInfo : unit -> {index : int, params : int} list +val go : Mono.file -> Mono.file + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sqlcache.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,1730 @@ +structure Sqlcache :> SQLCACHE = struct + + +(*********************) +(* General Utilities *) +(*********************) + +structure IK = struct type ord_key = int val compare = Int.compare end +structure IS = IntBinarySet +structure IM = IntBinaryMap +structure SK = struct type ord_key = string val compare = String.compare end +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) +structure IIMM = MultimapFn(structure KeyMap = IM structure ValSet = IS) +structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) + +fun id x = x + +fun iterate f n x = if n < 0 + then raise Fail "Can't iterate function negative number of times." + else if n = 0 + then x + else iterate f (n-1) (f x) + +(* From the MLton wiki. *) +infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *) +infix 3 \> fun f \> y = f y (* Left application *) + +fun mapFst f (x, y) = (f x, y) + +(* Option monad. *) +fun obind (x, f) = Option.mapPartial f x +fun oguard (b, x) = if b then x () else NONE +fun omap f = fn SOME x => SOME (f x) | _ => NONE +fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE +fun osequence ys = List.foldr (omap2 op::) (SOME []) ys + +fun concatMap f xs = List.concat (map f xs) + +val rec cartesianProduct : 'a list list -> 'a list list = + fn [] => [[]] + | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs) + (cartesianProduct xss) + +fun indexOf test = + let + fun f n = + fn [] => NONE + | (x::xs) => if test x then SOME n else f (n+1) xs + in + f 0 + end + + +(************) +(* Settings *) +(************) + +open Mono + +(* Filled in by [addFlushing]. *) +val ffiInfoRef : {index : int, params : int} list ref = ref [] + +fun resetFfiInfo () = ffiInfoRef := [] + +fun getFfiInfo () = !ffiInfoRef + +(* Some FFIs have writing as their only effect, which the caching records. *) +val ffiEffectful = + (* ASK: how can this be less hard-coded? *) + let + val okayWrites = SS.fromList ["htmlifyInt_w", + "htmlifyFloat_w", + "htmlifyString_w", + "htmlifyBool_w", + "htmlifyTime_w", + "attrifyInt_w", + "attrifyFloat_w", + "attrifyString_w", + "attrifyChar_w", + "urlifyInt_w", + "urlifyFloat_w", + "urlifyString_w", + "urlifyBool_w", + "urlifyChannel_w"] + in + (* ASK: is it okay to hardcode Sqlcache functions as effectful? *) + fn (m, f) => Settings.isEffectful (m, f) + andalso not (m = "Basis" andalso SS.member (okayWrites, f)) + end + +val cacheRef = ref LruCache.cache +fun setCache c = cacheRef := c +fun getCache () = !cacheRef + +datatype heuristic = Smart | Always | Never | NoPureAll | NoPureOne | NoCombo + +val heuristicRef = ref NoPureOne +fun setHeuristic h = heuristicRef := (case h of + "smart" => Smart + | "always" => Always + | "never" => Never + | "nopureall" => NoPureAll + | "nopureone" => NoPureOne + | "nocombo" => NoCombo + | _ => raise Fail "Sqlcache: setHeuristic") +fun getHeuristic () = !heuristicRef + + +(************************) +(* Really Useful Things *) +(************************) + +(* Used to have type context for local variables in MonoUtil functions. *) +val doBind = + fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE + | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s + | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs + +val dummyLoc = ErrorMsg.dummySpan + +(* DEBUG *) +fun printExp msg exp = + (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp); exp) +fun printExp' msg exp' = (printExp msg (exp', dummyLoc); exp') +fun printTyp msg typ = + (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ); typ) +fun printTyp' msg typ' = (printTyp msg (typ', dummyLoc); typ') +fun obindDebug printer (x, f) = + case x of + NONE => NONE + | SOME x' => case f x' of + NONE => (printer (); NONE) + | y => y + + +(*******************) +(* Effect Analysis *) +(*******************) + +(* TODO: test this. *) +fun transitiveAnalysis doVal state (decls, _) = + let + val doDecl = + fn ((DVal v, _), state) => doVal (v, state) + (* Pass over the list of values a number of times equal to its size, + making sure whatever property we're testing propagates everywhere + it should. This is analagous to the Bellman-Ford algorithm. *) + | ((DValRec vs, _), state) => + iterate (fn state => List.foldl doVal state vs) (length vs) state + | (_, state) => state + in + List.foldl doDecl state decls + end + +(* Makes an exception for [EWrite] (which is recorded when caching). *) +fun effectful (effs : IS.set) = + let + val isFunction = + fn (TFun _, _) => true + | _ => false + fun doExp (env, e) = + case e of + EPrim _ => false + (* For now: variables of function type might be effectful, but + others are fully evaluated and are therefore not effectful. *) + | ERel n => isFunction (#2 (MonoEnv.lookupERel env n)) + | ENamed n => IS.member (effs, n) + | EFfi (m, f) => ffiEffectful (m, f) + | EFfiApp (m, f, _) => ffiEffectful (m, f) + (* These aren't effectful unless a subexpression is. *) + | ECon _ => false + | ENone _ => false + | ESome _ => false + | EApp _ => false + | EAbs _ => false + | EUnop _ => false + | EBinop _ => false + | ERecord _ => false + | EField _ => false + | ECase _ => false + | EStrcat _ => false + (* EWrite is a special exception because we record writes when caching. *) + | EWrite _ => false + | ESeq _ => false + | ELet _ => false + | EUnurlify _ => false + (* ASK: what should we do about closures? *) + (* Everything else is some sort of effect. We could flip this and + explicitly list bits of Mono that are effectful, but this is + conservatively robust to future changes (however unlikely). *) + | _ => true + in + MonoUtil.Exp.existsB {typ = fn _ => false, exp = doExp, bind = doBind} + end + +(* TODO: test this. *) +fun effectfulDecls file = + transitiveAnalysis (fn ((_, name, _, e, _), effs) => + if effectful effs MonoEnv.empty e + then IS.add (effs, name) + else effs) + IS.empty + file + + +(*********************************) +(* Boolean Formula Normalization *) +(*********************************) + +datatype junctionType = Conj | Disj + +datatype 'atom formula = + Atom of 'atom + | Negate of 'atom formula + | Combo of junctionType * 'atom formula list + +(* Guaranteed to have all negation pushed to the atoms. *) +datatype 'atom formula' = + Atom' of 'atom + | Combo' of junctionType * 'atom formula' list + +val flipJt = fn Conj => Disj | Disj => Conj + +(* Pushes all negation to the atoms.*) +fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) = + fn Atom x => Atom' (normalizeAtom (negating, x)) + | Negate f => pushNegate normalizeAtom (not negating) f + | Combo (j, fs) => Combo' (if negating then flipJt j else j, + map (pushNegate normalizeAtom negating) fs) + +val rec flatten = + fn Combo' (_, [f]) => flatten f + | Combo' (j, fs) => + Combo' (j, List.foldr (fn (f, acc) => + case f of + Combo' (j', fs') => + if j = j' orelse length fs' = 1 + then fs' @ acc + else f :: acc + | _ => f :: acc) + [] + (map flatten fs)) + | f => f + +(* [simplify] operates on the desired normal form. E.g., if [junc] is [Disj], + consider the list of lists to be a disjunction of conjunctions. *) +fun normalize' (simplify : 'a list list -> 'a list list) + (junc : junctionType) = + let + fun norm junc = + simplify + o (fn Atom' x => [[x]] + | Combo' (j, fs) => + let + val fss = map (norm junc) fs + in + if j = junc + then List.concat fss + else map List.concat (cartesianProduct fss) + end) + in + norm junc + end + +fun normalize simplify normalizeAtom junc = + normalize' simplify junc + o flatten + o pushNegate normalizeAtom false + +fun mapFormula mf = + fn Atom x => Atom (mf x) + | Negate f => Negate (mapFormula mf f) + | Combo (j, fs) => Combo (j, map (mapFormula mf) fs) + +fun mapFormulaExps mf = mapFormula (fn (cmp, e1, e2) => (cmp, mf e1, mf e2)) + + +(****************) +(* SQL Analysis *) +(****************) + +structure CmpKey = struct + + type ord_key = Sql.cmp + + val compare = + fn (Sql.Eq, Sql.Eq) => EQUAL + | (Sql.Eq, _) => LESS + | (_, Sql.Eq) => GREATER + | (Sql.Ne, Sql.Ne) => EQUAL + | (Sql.Ne, _) => LESS + | (_, Sql.Ne) => GREATER + | (Sql.Lt, Sql.Lt) => EQUAL + | (Sql.Lt, _) => LESS + | (_, Sql.Lt) => GREATER + | (Sql.Le, Sql.Le) => EQUAL + | (Sql.Le, _) => LESS + | (_, Sql.Le) => GREATER + | (Sql.Gt, Sql.Gt) => EQUAL + | (Sql.Gt, _) => LESS + | (_, Sql.Gt) => GREATER + | (Sql.Ge, Sql.Ge) => EQUAL + +end + +val rec chooseTwos : 'a list -> ('a * 'a) list = + fn [] => [] + | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys + +fun removeRedundant madeRedundantBy zs = + let + fun removeRedundant' (xs, ys) = + case xs of + [] => ys + | x :: xs' => + removeRedundant' (xs', + if List.exists (fn y => madeRedundantBy (x, y)) (xs' @ ys) + then ys + else x :: ys) + in + removeRedundant' (zs, []) + end + +datatype atomExp = + True + | False + | QueryArg of int + | DmlRel of int + | Prim of Prim.t + | Field of string * string + +structure AtomExpKey : ORD_KEY = struct + + type ord_key = atomExp + + val compare = + fn (True, True) => EQUAL + | (True, _) => LESS + | (_, True) => GREATER + | (False, False) => EQUAL + | (False, _) => LESS + | (_, False) => GREATER + | (QueryArg n1, QueryArg n2) => Int.compare (n1, n2) + | (QueryArg _, _) => LESS + | (_, QueryArg _) => GREATER + | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2) + | (DmlRel _, _) => LESS + | (_, DmlRel _) => GREATER + | (Prim p1, Prim p2) => Prim.compare (p1, p2) + | (Prim _, _) => LESS + | (_, Prim _) => GREATER + | (Field (t1, f1), Field (t2, f2)) => + case String.compare (t1, t2) of + EQUAL => String.compare (f1, f2) + | ord => ord + +end + +structure AtomOptionKey = OptionKeyFn(AtomExpKey) + +val rec tablesOfQuery = + fn Sql.Query1 {From = fitems, ...} => List.foldl SS.union SS.empty (map tableOfFitem fitems) + | Sql.Union (q1, q2) => SS.union (tablesOfQuery q1, tablesOfQuery q2) +and tableOfFitem = + fn Sql.Table (t, _) => SS.singleton t + | Sql.Nested (q, _) => tablesOfQuery q + | Sql.Join (_, f1, f2, _) => SS.union (tableOfFitem f1, tableOfFitem f2) + +val tableOfDml = + fn Sql.Insert (tab, _) => tab + | Sql.Delete (tab, _) => tab + | Sql.Update (tab, _, _) => tab + +val freeVars = + MonoUtil.Exp.foldB + {typ = #2, + exp = fn (bound, ERel n, vars) => if n < bound + then vars + else IS.add (vars, n - bound) + | (_, _, vars) => vars, + bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + 0 + IS.empty + +(* A path is a number of field projections of a variable. *) +type path = int * string list +structure PK = PairKeyFn(structure I = IK structure J = ListKeyFn(SK)) +structure PS = BinarySetFn(PK) + +val pathOfExp = + let + fun readFields acc exp = + acc + <\obind\> + (fn fs => + case #1 exp of + ERel n => SOME (n, fs) + | EField (exp, f) => readFields (SOME (f::fs)) exp + | _ => NONE) + in + readFields (SOME []) + end + +fun expOfPath (n, fs) = + List.foldl (fn (f, exp) => (EField (exp, f), dummyLoc)) (ERel n, dummyLoc) fs + +fun freePaths'' bound exp paths = + case pathOfExp (exp, dummyLoc) of + NONE => paths + | SOME (n, fs) => if n < bound then paths else PS.add (paths, (n - bound, fs)) + +(* ASK: nicer way? :( *) +fun freePaths' bound exp = + case #1 exp of + EPrim _ => id + | e as ERel _ => freePaths'' bound e + | ENamed _ => id + | ECon (_, _, data) => (case data of NONE => id | SOME e => freePaths' bound e) + | ENone _ => id + | ESome (_, e) => freePaths' bound e + | EFfi _ => id + | EFfiApp (_, _, args) => + List.foldl (fn ((e, _), acc) => freePaths' bound e o acc) id args + | EApp (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | EAbs (_, _, _, e) => freePaths' (bound + 1) e + | EUnop (_, e) => freePaths' bound e + | EBinop (_, _, e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | ERecord fields => List.foldl (fn ((_, e, _), acc) => freePaths' bound e o acc) id fields + | e as EField _ => freePaths'' bound e + | ECase (e, cases, _) => + List.foldl (fn ((p, e), acc) => freePaths' (MonoEnv.patBindsN p + bound) e o acc) + (freePaths' bound e) + cases + | EStrcat (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | EError (e, _) => freePaths' bound e + | EReturnBlob {blob, mimeType = e, ...} => + freePaths' bound e o (case blob of NONE => id | SOME e => freePaths' bound e) + | ERedirect (e, _) => freePaths' bound e + | EWrite e => freePaths' bound e + | ESeq (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | ELet (_, _, e1, e2) => freePaths' bound e1 o freePaths' (bound + 1) e2 + | EClosure (_, es) => List.foldl (fn (e, acc) => freePaths' bound e o acc) id es + | EQuery {query = e1, body = e2, initial = e3, ...} => + freePaths' bound e1 o freePaths' (bound + 2) e2 o freePaths' bound e3 + | EDml (e, _) => freePaths' bound e + | ENextval e => freePaths' bound e + | ESetval (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | EUnurlify (e, _, _) => freePaths' bound e + | EJavaScript (_, e) => freePaths' bound e + | ESignalReturn e => freePaths' bound e + | ESignalBind (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | ESignalSource e => freePaths' bound e + | EServerCall (e, _, _, _) => freePaths' bound e + | ERecv (e, _) => freePaths' bound e + | ESleep e => freePaths' bound e + | ESpawn e => freePaths' bound e + +fun freePaths exp = freePaths' 0 exp PS.empty + +datatype unbind = Known of exp | Unknowns of int + +datatype cacheArg = AsIs of exp | Urlify of exp + +structure InvalInfo :> sig + type t + type state = {tableToIndices : SIMM.multimap, + indexToInvalInfo : (t * int) IntBinaryMap.map, + ffiInfo : {index : int, params : int} list, + index : int} + val empty : t + val singleton : Sql.query -> t + val query : t -> Sql.query + val orderArgs : t * Mono.exp -> cacheArg list option + val unbind : t * unbind -> t option + val union : t * t -> t + val updateState : t * int * state -> state +end = struct + + (* Variable, field projections, possible wrapped sqlification FFI call. *) + type sqlArg = path * (string * string * typ) option + + type subst = sqlArg IM.map + + (* TODO: store free variables as well? *) + type t = (Sql.query * subst) list + + type state = {tableToIndices : SIMM.multimap, + indexToInvalInfo : (t * int) IntBinaryMap.map, + ffiInfo : {index : int, params : int} list, + index : int} + + structure AK = PairKeyFn( + structure I = PK + structure J = OptionKeyFn(TripleKeyFn( + structure I = SK + structure J = SK + structure K = struct type ord_key = Mono.typ val compare = MonoUtil.Typ.compare end))) + structure AS = BinarySetFn(AK) + structure AM = BinaryMapFn(AK) + + (* Traversal Utilities *) + (* TODO: get rid of unused ones. *) + + (* Need lift', etc. because we don't have rank-2 polymorphism. This should + probably use a functor (an ML one, not Haskell) but works for now. *) + fun traverseSqexp (pure, _, _, _, lift, lift', _, _, lift2, _, _, _, _, _) f = + let + val rec tr = + fn Sql.SqNot se => lift Sql.SqNot (tr se) + | Sql.Binop (r, se1, se2) => + lift2 (fn (trse1, trse2) => Sql.Binop (r, trse1, trse2)) (tr se1, tr se2) + | Sql.SqKnown se => lift Sql.SqKnown (tr se) + | Sql.Inj (e', loc) => lift' (fn fe' => Sql.Inj (fe', loc)) (f e') + | Sql.SqFunc (s, se) => lift (fn trse => Sql.SqFunc (s, trse)) (tr se) + | se => pure se + in + tr + end + + fun traverseFitem (ops as (_, _, _, pure''', _, _, _, lift''', _, _, _, _, lift2'''', lift2''''')) f = + let + val rec tr = + fn Sql.Table t => pure''' (Sql.Table t) + | Sql.Join (jt, fi1, fi2, se) => + lift2'''' (fn ((trfi1, trfi2), trse) => Sql.Join (jt, trfi1, trfi2, trse)) + (lift2''''' id (tr fi1, tr fi2), traverseSqexp ops f se) + | Sql.Nested (q, s) => lift''' (fn trq => Sql.Nested (trq, s)) + (traverseQuery ops f q) + in + tr + end + + and traverseQuery (ops as (_, pure', pure'', _, _, _, lift'', _, _, lift2', lift2'', lift2''', _, _)) f = + let + val rec seqList = + fn [] => pure'' [] + | (x::xs) => lift2''' op:: (x, seqList xs) + val rec tr = + fn Sql.Query1 q => + (* TODO: make sure we don't need to traverse [#Select q]. *) + lift2' (fn (trfrom, trwher) => Sql.Query1 {Select = #Select q, + From = trfrom, + Where = trwher}) + (seqList (map (traverseFitem ops f) (#From q)), + case #Where q of + NONE => pure' NONE + | SOME se => lift'' SOME (traverseSqexp ops f se)) + | Sql.Union (q1, q2) => lift2'' Sql.Union (tr q1, tr q2) + in + tr + end + + (* Include unused tuple elements in argument for convenience of using same + argument as [traverseQuery]. *) + fun traverseIM (pure, _, _, _, _, _, _, _, _, lift2, _, _, _, _) f = + IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v))) + (pure IM.empty) + + fun traverseSubst (ops as (_, pure', _, _, lift, _, _, _, _, lift2', _, _, _, _)) f = + let + fun mp ((n, fields), sqlify) = + lift (fn ((n', fields'), sqlify') => + let + fun wrap sq = ((n', fields' @ fields), sq) + in + case (fields', sqlify', fields, sqlify) of + (_, NONE, _, NONE) => wrap NONE + | (_, NONE, _, sq as SOME _) => wrap sq + (* Last case should suffice because we don't + project from a sqlified value (which is a + string). *) + | (_, sq as SOME _, [], NONE) => wrap sq + | _ => raise Fail "Sqlcache: traverseSubst" + end) + (f n) + in + traverseIM ops (fn (_, v) => mp v) + end + + fun monoidOps plus zero = + (fn _ => zero, fn _ => zero, fn _ => zero, fn _ => zero, + fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, + fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus) + + val optionOps = (SOME, SOME, SOME, SOME, + omap, omap, omap, omap, + omap2, omap2, omap2, omap2, omap2, omap2) + + fun foldMapQuery plus zero = traverseQuery (monoidOps plus zero) + val omapQuery = traverseQuery optionOps + fun foldMapIM plus zero = traverseIM (monoidOps plus zero) + fun omapIM f = traverseIM optionOps f + fun foldMapSubst plus zero = traverseSubst (monoidOps plus zero) + fun omapSubst f = traverseSubst optionOps f + + val varsOfQuery = foldMapQuery IS.union + IS.empty + (fn e' => freeVars (e', dummyLoc)) + + fun varsOfSubst subst = foldMapSubst IS.union IS.empty IS.singleton subst + + val varsOfList = + fn [] => IS.empty + | (q::qs) => varsOfQuery (List.foldl Sql.Union q qs) + + (* Signature Implementation *) + + val empty = [] + + fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, ((n, []), NONE))) + IM.empty + (varsOfQuery q))] + + val union = op@ + + fun sqlArgsSet (q, subst) = + IM.foldl AS.add' AS.empty subst + + fun sqlArgsMap (qs : t) = + let + val args = + List.foldl (fn ((q, subst), acc) => + IM.foldl (fn (arg, acc) => AM.insert (acc, arg, ())) acc subst) + AM.empty + qs + val countRef = ref (~1) + fun count () = (countRef := !countRef + 1; !countRef) + in + (* Maps each arg to a different consecutive integer, starting from 0. *) + AM.map count args + end + + fun expOfArg (path, sqlify) = + let + val exp = expOfPath path + in + case sqlify of + NONE => exp + | SOME (m, x, typ) => (EFfiApp (m, x, [(exp, typ)]), dummyLoc) + end + + fun orderArgs (qs : t, exp) = + let + val paths = freePaths exp + fun erel n = (ERel n, dummyLoc) + val argsMap = sqlArgsMap qs + val args = map (expOfArg o #1) (AM.listItemsi argsMap) + val invalPaths = List.foldl PS.union PS.empty (map freePaths args) + (* TODO: make sure these variables are okay to remove from the argument list. *) + val pureArgs = PS.difference (paths, invalPaths) + val shouldCache = + case getHeuristic () of + Smart => + (case (qs, PS.numItems pureArgs) of + ((q::qs), 0) => + let + val args = sqlArgsSet q + val argss = map sqlArgsSet qs + fun test (args, acc) = + acc + <\obind\> + (fn args' => + let + val both = AS.union (args, args') + in + (AS.numItems args = AS.numItems both + orelse AS.numItems args' = AS.numItems both) + <\oguard\> + (fn _ => SOME both) + end) + in + case List.foldl test (SOME args) argss of + NONE => false + | SOME _ => true + end + | _ => false) + | Always => true + | Never => (case qs of [_] => PS.numItems pureArgs = 0 | _ => false) + | NoPureAll => (case qs of [] => false | _ => true) + | NoPureOne => (case qs of [] => false | _ => PS.numItems pureArgs = 0) + | NoCombo => PS.numItems pureArgs = 0 orelse AM.numItems argsMap = 0 + in + (* Put arguments we might invalidate by first. *) + if shouldCache + then SOME (map AsIs args @ map (Urlify o expOfPath) (PS.listItems pureArgs)) + else NONE + end + + (* As a kludge, we rename the variables in the query to correspond to the + argument of the cache they're part of. *) + fun query (qs : t) = + let + val argsMap = sqlArgsMap qs + fun substitute subst = + fn ERel n => IM.find (subst, n) + <\obind\> + (fn arg => + AM.find (argsMap, arg) + <\obind\> + (fn n' => SOME (ERel n'))) + | _ => raise Fail "Sqlcache: query (a)" + in + case (map #1 qs) of + (q :: qs) => + let + val q = List.foldl Sql.Union q qs + val ns = IS.listItems (varsOfQuery q) + val rename = + fn ERel n => omap ERel (indexOf (fn n' => n' = n) ns) + | _ => raise Fail "Sqlcache: query (b)" + in + case omapQuery rename q of + SOME q => q + (* We should never get NONE because indexOf should never fail. *) + | NONE => raise Fail "Sqlcache: query (c)" + end + (* We should never reach this case because [updateState] won't + put anything in the state if there are no queries. *) + | [] => raise Fail "Sqlcache: query (d)" + end + + val argOfExp = + let + fun doFields acc exp = + acc + <\obind\> + (fn (fs, sqlify) => + case #1 exp of + ERel n => SOME (n, fs, sqlify) + | EField (exp, f) => doFields (SOME (f::fs, sqlify)) exp + | _ => NONE) + in + fn (EFfiApp ("Basis", x, [(exp, typ)]), _) => + if String.isPrefix "sqlify" x + then omap (fn path => (path, SOME ("Basis", x, typ))) (pathOfExp exp) + else NONE + | exp => omap (fn path => (path, NONE)) (pathOfExp exp) + end + + val unbind1 = + fn Known e => + let + val replacement = argOfExp e + in + omapSubst (fn 0 => replacement + | n => SOME ((n-1, []), NONE)) + end + | Unknowns k => omapSubst (fn n => if n < k then NONE else SOME ((n-k, []), NONE)) + + fun unbind (qs, ub) = + case ub of + (* Shortcut if nothing's changing. *) + Unknowns 0 => SOME qs + | _ => osequence (map (fn (q, subst) => unbind1 ub subst + <\obind\> + (fn subst' => SOME (q, subst'))) qs) + + fun updateState (qs, numArgs, state as {index, ...} : state) = + {tableToIndices = List.foldr (fn ((q, _), acc) => + SS.foldl (fn (tab, acc) => + SIMM.insert (acc, tab, index)) + acc + (tablesOfQuery q)) + (#tableToIndices state) + qs, + indexToInvalInfo = IM.insert (#indexToInvalInfo state, index, (qs, numArgs)), + ffiInfo = {index = index, params = numArgs} :: #ffiInfo state, + index = index + 1} + +end + +structure UF = UnionFindFn(AtomExpKey) + +val rec sqexpToFormula = + fn Sql.SqTrue => Combo (Conj, []) + | Sql.SqFalse => Combo (Disj, []) + | Sql.SqNot e => Negate (sqexpToFormula e) + | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2) + | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj, + [sqexpToFormula p1, sqexpToFormula p2]) + | e as Sql.Field f => Atom (Sql.Eq, e, Sql.SqTrue) + (* ASK: any other sqexps that can be props? *) + | Sql.SqConst prim => + (case prim of + (Prim.String (Prim.Normal, s)) => + if s = #trueString (Settings.currentDbms ()) + then Combo (Conj, []) + else if s = #falseString (Settings.currentDbms ()) + then Combo (Disj, []) + else raise Fail "Sqlcache: sqexpToFormula (SqConst a)" + | _ => raise Fail "Sqlcache: sqexpToFormula (SqConst b)") + | Sql.Computed _ => raise Fail "Sqlcache: sqexpToFormula (Computed)" + | Sql.SqKnown _ => raise Fail "Sqlcache: sqexpToFormula (SqKnown)" + | Sql.Inj _ => raise Fail "Sqlcache: sqexpToFormula (Inj)" + | Sql.SqFunc _ => raise Fail "Sqlcache: sqexpToFormula (SqFunc)" + | Sql.Unmodeled => raise Fail "Sqlcache: sqexpToFormula (Unmodeled)" + | Sql.Null => raise Fail "Sqlcache: sqexpToFormula (Null)" + +fun mapSqexpFields f = + fn Sql.Field (t, v) => f (t, v) + | Sql.SqNot e => Sql.SqNot (mapSqexpFields f e) + | Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2) + | Sql.SqKnown e => Sql.SqKnown (mapSqexpFields f e) + | Sql.SqFunc (s, e) => Sql.SqFunc (s, mapSqexpFields f e) + | e => e + +fun renameTables tablePairs = + let + fun rename table = + case List.find (fn (_, t) => table = t) tablePairs of + NONE => table + | SOME (realTable, _) => realTable + in + mapSqexpFields (fn (t, f) => Sql.Field (rename t, f)) + end + +structure FlattenQuery = struct + + datatype substitution = RenameTable of string | SubstituteExp of Sql.sqexp SM.map + + fun applySubst substTable = + let + fun substitute (table, field) = + case SM.find (substTable, table) of + NONE => Sql.Field (table, field) + | SOME (RenameTable realTable) => Sql.Field (realTable, field) + | SOME (SubstituteExp substField) => + case SM.find (substField, field) of + NONE => raise Fail "Sqlcache: applySubst" + | SOME se => se + in + mapSqexpFields substitute + end + + fun addToSubst (substTable, table, substField) = + SM.insert (substTable, + table, + case substField of + RenameTable _ => substField + | SubstituteExp subst => SubstituteExp (SM.map (applySubst substTable) subst)) + + fun newSubst (t, s) = addToSubst (SM.empty, t, s) + + datatype sitem' = Named of Sql.sqexp * string | Unnamed of Sql.sqexp + + type queryFlat = {Select : sitem' list, Where : Sql.sqexp} + + val sitemsToSubst = + List.foldl (fn (Named (se, s), acc) => SM.insert (acc, s, se) + | (Unnamed _, _) => raise Fail "Sqlcache: sitemsToSubst") + SM.empty + + fun unionSubst (s1, s2) = SM.unionWith (fn _ => raise Fail "Sqlcache: unionSubst") (s1, s2) + + fun sqlAnd (se1, se2) = Sql.Binop (Sql.RLop Sql.And, se1, se2) + + val rec flattenFitem : Sql.fitem -> (Sql.sqexp * substitution SM.map) list = + fn Sql.Table (real, alias) => [(Sql.SqTrue, newSubst (alias, RenameTable real))] + | Sql.Nested (q, s) => + let + val qfs = flattenQuery q + in + map (fn (qf, subst) => + (#Where qf, addToSubst (subst, s, SubstituteExp (sitemsToSubst (#Select qf))))) + qfs + end + | Sql.Join (jt, fi1, fi2, se) => + concatMap (fn ((wher1, subst1)) => + map (fn (wher2, subst2) => + let + val subst = unionSubst (subst1, subst2) + in + (* ON clause becomes part of the accumulated WHERE. *) + (sqlAnd (sqlAnd (wher1, wher2), applySubst subst se), subst) + end) + (flattenFitem fi2)) + (flattenFitem fi1) + + and flattenQuery : Sql.query -> (queryFlat * substitution SM.map) list = + fn Sql.Query1 q => + let + val fifss = cartesianProduct (map flattenFitem (#From q)) + in + map (fn fifs => + let + val subst = List.foldl (fn ((_, subst), acc) => unionSubst (acc, subst)) + SM.empty + fifs + val wher = List.foldr (fn ((wher, _), acc) => sqlAnd (wher, acc)) + (case #Where q of + NONE => Sql.SqTrue + | SOME wher => wher) + fifs + in + (* ASK: do we actually need to pass the substitution through here? *) + (* We use the substitution later, but it's not clear we + need any of its currently present fields again. *) + ({Select = map (fn Sql.SqExp (se, s) => Named (applySubst subst se, s) + | Sql.SqField tf => + Unnamed (applySubst subst (Sql.Field tf))) + (#Select q), + Where = applySubst subst wher}, + subst) + end) + fifss + end + | Sql.Union (q1, q2) => (flattenQuery q1) @ (flattenQuery q2) + +end + +val flattenQuery = map #1 o FlattenQuery.flattenQuery + +fun queryFlatToFormula marker {Select = sitems, Where = wher} = + let + val fWhere = sqexpToFormula wher + in + case marker of + NONE => fWhere + | SOME markFields => + let + val fWhereMarked = mapFormulaExps markFields fWhere + val toSqexp = + fn FlattenQuery.Named (se, _) => se + | FlattenQuery.Unnamed se => se + fun ineq se = Atom (Sql.Ne, se, markFields se) + val fIneqs = Combo (Disj, map (ineq o toSqexp) sitems) + in + (Combo (Conj, + [fWhere, + Combo (Disj, + [Negate fWhereMarked, + Combo (Conj, [fWhereMarked, fIneqs])])])) + end + end + +fun queryToFormula marker q = Combo (Disj, map (queryFlatToFormula marker) (flattenQuery q)) + +fun valsToFormula (markLeft, markRight) (table, vals) = + Combo (Conj, + map (fn (field, v) => Atom (Sql.Eq, markLeft (Sql.Field (table, field)), markRight v)) + vals) + +(* TODO: verify logic for insertion and deletion. *) +val rec dmlToFormulaMarker = + fn Sql.Insert (table, vals) => (valsToFormula (id, id) (table, vals), NONE) + | Sql.Delete (table, wher) => (sqexpToFormula (renameTables [(table, "T")] wher), NONE) + | Sql.Update (table, vals, wher) => + let + val fWhere = sqexpToFormula (renameTables [(table, "T")] wher) + fun fVals marks = valsToFormula marks (table, vals) + val modifiedFields = SS.addList (SS.empty, map #1 vals) + (* TODO: don't use field name hack. *) + val markFields = + mapSqexpFields (fn (t, v) => if t = table andalso SS.member (modifiedFields, v) + then Sql.Field (t, v ^ "'") + else Sql.Field (t, v)) + val mark = mapFormulaExps markFields + in + ((Combo (Disj, [Combo (Conj, [fVals (id, markFields), mark fWhere]), + Combo (Conj, [fVals (markFields, id), fWhere])])), + SOME markFields) + end + +fun pairToFormulas (query, dml) = + let + val (fDml, marker) = dmlToFormulaMarker dml + in + (queryToFormula marker query, fDml) + end + +structure ConflictMaps = struct + + structure TK = TripleKeyFn(structure I = CmpKey + structure J = AtomOptionKey + structure K = AtomOptionKey) + + structure TS : ORD_SET = BinarySetFn(TK) + + val toKnownEquality = + (* [NONE] here means unkown. Anything that isn't a comparison between two + knowns shouldn't be used, and simply dropping unused terms is okay in + disjunctive normal form. *) + fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2) + | _ => NONE + + fun equivClasses atoms : atomExp list list option = + let + val uf = List.foldl UF.union' UF.empty (List.mapPartial toKnownEquality atoms) + val contradiction = + fn (cmp, SOME ae1, SOME ae2) => (cmp = Sql.Ne orelse cmp = Sql.Lt orelse cmp = Sql.Gt) + andalso UF.together (uf, ae1, ae2) + (* If we don't know one side of the comparision, not a contradiction. *) + | _ => false + in + not (List.exists contradiction atoms) <\oguard\> (fn _ => SOME (UF.classes uf)) + end + + fun addToEqs (eqs, n, e) = + case IM.find (eqs, n) of + (* Comparing to a constant is probably better than comparing to a + variable? Checking that existing constants match a new ones is + handled by [accumulateEqs]. *) + SOME (Prim _) => eqs + | _ => IM.insert (eqs, n, e) + + val accumulateEqs = + (* [NONE] means we have a contradiction. *) + fn (_, NONE) => NONE + | ((Prim p1, Prim p2), eqso) => + (case Prim.compare (p1, p2) of + EQUAL => eqso + | _ => NONE) + | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) + | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) + | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) + | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) + (* TODO: deal with equalities between [DmlRel]s and [Prim]s. + This would involve guarding the invalidation with a check for the + relevant comparisons. *) + | (_, eqso) => eqso + + val eqsOfClass : atomExp list -> atomExp IM.map option = + List.foldl accumulateEqs (SOME IM.empty) + o chooseTwos + + fun toAtomExps rel (cmp, e1, e2) = + let + val qa = + (* Here [NONE] means unkown. *) + fn Sql.SqConst p => SOME (Prim p) + | Sql.Field tf => SOME (Field tf) + | Sql.Inj (EPrim p, _) => SOME (Prim p) + | Sql.Inj (ERel n, _) => SOME (rel n) + (* We can't deal with anything else, e.g., CURRENT_TIMESTAMP + becomes Sql.Unmodeled, which becomes NONE here. *) + | _ => NONE + in + (cmp, qa e1, qa e2) + end + + val negateCmp = + fn Sql.Eq => Sql.Ne + | Sql.Ne => Sql.Eq + | Sql.Lt => Sql.Ge + | Sql.Le => Sql.Gt + | Sql.Gt => Sql.Le + | Sql.Ge => Sql.Lt + + fun normalizeAtom (negating, (cmp, e1, e2)) = + (* Restricting to Le/Lt and sorting the expressions in Eq/Ne helps with + simplification, where we put the triples in sets. *) + case (if negating then negateCmp cmp else cmp) of + Sql.Eq => (case AtomOptionKey.compare (e1, e2) of + LESS => (Sql.Eq, e2, e1) + | _ => (Sql.Eq, e1, e2)) + | Sql.Ne => (case AtomOptionKey.compare (e1, e2) of + LESS => (Sql.Ne, e2, e1) + | _ => (Sql.Ne, e1, e2)) + | Sql.Lt => (Sql.Lt, e1, e2) + | Sql.Le => (Sql.Le, e1, e2) + | Sql.Gt => (Sql.Lt, e2, e1) + | Sql.Ge => (Sql.Le, e2, e1) + + val markQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula -> + (Sql.cmp * atomExp option * atomExp option) formula = + mapFormula (toAtomExps QueryArg) + + val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula -> + (Sql.cmp * atomExp option * atomExp option) formula = + mapFormula (toAtomExps DmlRel) + + (* No eqs should have key conflicts because no variable is in two + equivalence classes. *) + val mergeEqs : (atomExp IntBinaryMap.map option list + -> atomExp IntBinaryMap.map option) = + List.foldr (omap2 (IM.unionWith (fn _ => raise Fail "Sqlcache: ConflictMaps.mergeEqs"))) + (SOME IM.empty) + + val simplify = + map TS.listItems + o removeRedundant (fn (x, y) => TS.isSubset (y, x)) + o map (fn xs => TS.addList (TS.empty, xs)) + + fun dnf (fQuery, fDml) = + normalize simplify normalizeAtom Disj (Combo (Conj, [markQuery fQuery, markDml fDml])) + + val conflictMaps = + List.mapPartial (mergeEqs o map eqsOfClass) + o List.mapPartial equivClasses + o dnf + +end + +val conflictMaps = ConflictMaps.conflictMaps + + +(*************************************) +(* Program Instrumentation Utilities *) +(*************************************) + +val {check, store, flush, lock, ...} = getCache () + +val dummyTyp = (TRecord [], dummyLoc) + +fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc) + +val stringTyp = (TFfi ("Basis", "string"), dummyLoc) + +val sequence = + fn (exp :: exps) => + let + val loc = dummyLoc + in + List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps + end + | _ => raise Fail "Sqlcache: sequence" + +(* Always increments negative indices as a hack we use later. *) +fun incRels inc = + MonoUtil.Exp.mapB + {typ = fn t' => t', + exp = fn bound => + (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n) + | e' => e'), + bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} + 0 + +fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state = + let + fun doVal env ((x, n, t, exp, s), state) = + let + val (exp, state) = doTopLevelExp env exp state + in + ((x, n, t, exp, s), state) + end + fun doDecl' env (decl', state) = + case decl' of + DVal v => + let + val (v, state) = doVal env (v, state) + in + (DVal v, state) + end + | DValRec vs => + let + val (vs, state) = ListUtil.foldlMap (doVal env) state vs + in + (DValRec vs, state) + end + | _ => (decl', state) + fun doDecl (decl as (decl', loc), (env, state)) = + let + val env = MonoEnv.declBinds env decl + val (decl', state) = doDecl' env (decl', state) + in + ((decl', loc), (env, state)) + end + val (decls, (_, state)) = (ListUtil.foldlMap doDecl (MonoEnv.empty, state) decls) + in + ((decls, sideInfo), state) + end + +fun fileAllMapfoldB doExp file start = + case MonoUtil.File.mapfoldB + {typ = Search.return2, + exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s), + decl = fn _ => Search.return2, + bind = doBind} + MonoEnv.empty file start of + Search.Continue x => x + | Search.Return _ => raise Fail "Sqlcache: fileAllMapfoldB" + +fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) + +(* TODO: make this a bit prettier.... *) +(* TODO: factour out identical subexpressions to the same variable.... *) +val simplifySql = + let + fun factorOutNontrivial text = + let + val loc = dummyLoc + val strcat = + fn (e1, (EPrim (Prim.String (Prim.Normal, "")), _)) => e1 + | ((EPrim (Prim.String (Prim.Normal, "")), _), e2) => e2 + | (e1, e2) => (EStrcat (e1, e2), loc) + val chunks = Sql.chunkify text + val (newText, newVariables) = + (* Important that this is foldr (to oppose foldl below). *) + List.foldr + (fn (chunk, (qText, newVars)) => + (* Variable bound to the head of newVars will have the lowest index. *) + case chunk of + (* EPrim should always be a string in this case. *) + Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) + | Sql.Exp e => + let + val n = length newVars + in + (* This is the (n+1)th new variable, so there are + already n new variables bound, so we increment + indices by n. *) + (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) + end + | Sql.String s => (strcat (stringExp s, qText), newVars)) + (stringExp "", []) + chunks + fun wrapLets e' = + (* Important that this is foldl (to oppose foldr above). *) + List.foldl (fn (v, e') => ELet ("sqlArg", stringTyp, v, (e', loc))) + e' + newVariables + val numArgs = length newVariables + in + (newText, wrapLets, numArgs) + end + fun doExp exp' = + let + val text = case exp' of + EQuery {query = text, ...} => text + | EDml (text, _) => text + | _ => raise Fail "Sqlcache: simplifySql (a)" + val (newText, wrapLets, numArgs) = factorOutNontrivial text + val newExp' = case exp' of + EQuery q => EQuery {query = newText, + exps = #exps q, + tables = #tables q, + state = #state q, + body = #body q, + initial = #initial q} + | EDml (_, failureMode) => EDml (newText, failureMode) + | _ => raise Fail "Sqlcache: simplifySql (b)" + in + (* Increment once for each new variable just made. This is + where we use the negative De Bruijn indices hack. *) + (* TODO: please don't use that hack. As anyone could have + predicted, it was incomprehensible a year later.... *) + wrapLets (#1 (incRels numArgs (newExp', dummyLoc))) + end + in + fileMap (fn exp' => case exp' of + EQuery _ => doExp exp' + | EDml _ => doExp exp' + | _ => exp') + end + + +(**********************) +(* Mono Type Checking *) +(**********************) + +fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = + fn EPrim p => SOME (TFfi ("Basis", case p of + Prim.Int _ => "int" + | Prim.Float _ => "double" + | Prim.String _ => "string" + | Prim.Char _ => "char"), + dummyLoc) + | ERel n => SOME (#2 (MonoEnv.lookupERel env n)) + | ENamed n => SOME (#2 (MonoEnv.lookupENamed env n)) + (* ASK: okay to make a new [ref] each time? *) + | ECon (dk, PConVar nCon, _) => + let + val (_, _, nData) = MonoEnv.lookupConstructor env nCon + val (_, cs) = MonoEnv.lookupDatatype env nData + in + SOME (TDatatype (nData, ref (dk, cs)), dummyLoc) + end + | ECon (_, PConFfi {mod = s, datatyp, ...}, _) => SOME (TFfi (s, datatyp), dummyLoc) + | ENone t => SOME (TOption t, dummyLoc) + | ESome (t, _) => SOME (TOption t, dummyLoc) + | EFfi _ => NONE + | EFfiApp _ => NONE + | EApp (e1, e2) => (case typOfExp env e1 of + SOME (TFun (_, t), _) => SOME t + | _ => NONE) + | EAbs (_, t1, t2, _) => SOME (TFun (t1, t2), dummyLoc) + (* ASK: is this right? *) + | EUnop (unop, e) => (case unop of + "!" => SOME (TFfi ("Basis", "bool"), dummyLoc) + | "-" => typOfExp env e + | _ => NONE) + (* ASK: how should this (and other "=> NONE" cases) work? *) + | EBinop _ => NONE + | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc) + | EField (e, s) => (case typOfExp env e of + SOME (TRecord fields, _) => + omap #2 (List.find (fn (s', _) => s = s') fields) + | _ => NONE) + | ECase (_, _, {result, ...}) => SOME result + | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc) + | EWrite _ => SOME (TRecord [], dummyLoc) + | ESeq (_, e) => typOfExp env e + | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2 + | EClosure _ => NONE + | EUnurlify (_, t, _) => SOME t + | EQuery {state, ...} => SOME state + | e => NONE + +and typOfExp env (e', loc) = typOfExp' env e' + + +(***********) +(* Caching *) +(***********) + +type state = InvalInfo.state + +datatype subexp = Cachable of InvalInfo.t * (state -> exp * state) | Impure of exp + +val isImpure = + fn Cachable _ => false + | Impure _ => true + +val runSubexp : subexp * state -> exp * state = + fn (Cachable (_, f), state) => f state + | (Impure e, state) => (e, state) + +val invalInfoOfSubexp = + fn Cachable (invalInfo, _) => invalInfo + | Impure _ => raise Fail "Sqlcache: invalInfoOfSubexp" + +fun cacheWrap (env, exp, typ, args, index) = + let + val loc = dummyLoc + val rel0 = (ERel 0, loc) + in + case MonoFooify.urlify env (rel0, typ) of + NONE => NONE + | SOME urlified => + let + (* We ensure before this step that all arguments aren't effectful. + by turning them into local variables as needed. *) + val argsInc = map (incRels 1) args + val check = (check (index, args), loc) + val store = (store (index, argsInc, urlified), loc) + in + SOME (ECase (check, + [((PNone stringTyp, loc), + (ELet ("q", typ, exp, (ESeq (store, rel0), loc)), loc)), + ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), + (* Boolean is false because we're not unurlifying from a cookie. *) + (EUnurlify (rel0, typ, false), loc))], + {disc = (TOption stringTyp, loc), result = typ})) + end + end + +val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0 + +(* TODO: pick a number. *) +val sizeWorthCaching = 5 + +val worthCaching = + fn EQuery _ => true + | exp' => expSize (exp', dummyLoc) > sizeWorthCaching + +fun cacheExp (env, exp', invalInfo, state : state) = + case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of + NONE => NONE + | SOME (TFun _, _) => NONE + | SOME typ => + InvalInfo.orderArgs (invalInfo, (exp', dummyLoc)) + <\obind\> + (fn args => + List.foldr (fn (arg, acc) => + acc + <\obind\> + (fn args' => + (case arg of + AsIs exp => SOME exp + | Urlify exp => + typOfExp env exp + <\obind\> + (fn typ => (MonoFooify.urlify env (exp, typ)))) + <\obind\> + (fn arg' => SOME (arg' :: args')))) + (SOME []) + args + <\obind\> + (fn args' => + cacheWrap (env, (exp', dummyLoc), typ, args', #index state) + <\obind\> + (fn cachedExp => + SOME (cachedExp, + InvalInfo.updateState (invalInfo, length args', state))))) + +fun cacheQuery (effs, env, q) : subexp = + let + (* We use dummyTyp here. I think this is okay because databases don't + store (effectful) functions, but perhaps there's some pathalogical + corner case missing.... *) + fun safe bound = + not + o effectful effs + (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) + bound + env) + val {query = queryText, initial, body, ...} = q + val attempt = + (* Ziv misses Haskell's do notation.... *) + (safe 0 queryText andalso safe 0 initial andalso safe 2 body) + <\oguard\> + (fn _ => + Sql.parse Sql.query queryText + <\obind\> + (fn queryParsed => + let + val invalInfo = InvalInfo.singleton queryParsed + fun mkExp state = + case cacheExp (env, EQuery q, invalInfo, state) of + NONE => ((EQuery q, dummyLoc), state) + | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state) + in + SOME (Cachable (invalInfo, mkExp)) + end)) + in + case attempt of + NONE => Impure (EQuery q, dummyLoc) + | SOME subexp => subexp + end + +fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = + let + fun wrapBindN (f : exp list -> exp') + (args : ((MonoEnv.env * exp) * unbind) list) = + let + val (subexps, state) = + ListUtil.foldlMap (cacheTree effs) + state + (map #1 args) + fun mkExp state = mapFst (fn exps => (f exps, loc)) + (ListUtil.foldlMap runSubexp state subexps) + val attempt = + if List.exists isImpure subexps + then NONE + else (List.foldl (omap2 InvalInfo.union) + (SOME InvalInfo.empty) + (ListPair.map + (fn (subexp, (_, unbinds)) => + InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds)) + (subexps, args))) + <\obind\> + (fn invalInfo => + SOME (Cachable (invalInfo, + fn state => + case cacheExp (env, + f (map (#2 o #1) args), + invalInfo, + state) of + NONE => mkExp state + | SOME (e', state) => ((e', loc), state)), + state)) + in + case attempt of + SOME (subexp, state) => (subexp, state) + | NONE => mapFst Impure (mkExp state) + end + fun wrapBind1 f arg = + wrapBindN (fn [arg] => f arg + | _ => raise Fail "Sqlcache: cacheTree (a)") [arg] + fun wrapBind2 f (arg1, arg2) = + wrapBindN (fn [arg1, arg2] => f (arg1, arg2) + | _ => raise Fail "Sqlcache: cacheTree (b)") [arg1, arg2] + fun wrapN f es = wrapBindN f (map (fn e => ((env, e), Unknowns 0)) es) + fun wrap1 f e = wrapBind1 f ((env, e), Unknowns 0) + fun wrap2 f (e1, e2) = wrapBind2 f (((env, e1), Unknowns 0), ((env, e2), Unknowns 0)) + in + case exp' of + ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e + | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e + | EFfiApp (s1, s2, args) => + if ffiEffectful (s1, s2) + then (Impure exp, state) + else wrapN (fn es => + EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args))) + (map #1 args) + | EApp (e1, e2) => wrap2 EApp (e1, e2) + | EAbs (s, t1, t2, e) => + wrapBind1 (fn e => EAbs (s, t1, t2, e)) + ((MonoEnv.pushERel env s t1 NONE, e), Unknowns 1) + | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e + | EBinop (bi, s, e1, e2) => wrap2 (fn (e1, e2) => EBinop (bi, s, e1, e2)) (e1, e2) + | ERecord fields => + wrapN (fn es => ERecord (ListPair.map (fn (e, (s, _, t)) => (s, e, t)) (es, fields))) + (map #2 fields) + | EField (e, s) => wrap1 (fn e => EField (e, s)) e + | ECase (e, cases, {disc, result}) => + wrapBindN (fn (e::es) => + ECase (e, + (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)), + {disc = disc, result = result}) + | _ => raise Fail "Sqlcache: cacheTree (c)") + (((env, e), Unknowns 0) + :: map (fn (p, e) => + ((MonoEnv.patBinds env p, e), Unknowns (MonoEnv.patBindsN p))) + cases) + | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2) + (* We record page writes, so they're cachable. *) + | EWrite e => wrap1 EWrite e + | ESeq (e1, e2) => wrap2 ESeq (e1, e2) + | ELet (s, t, e1, e2) => + wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2)) + (((env, e1), Unknowns 0), + ((MonoEnv.pushERel env s t (SOME e1), e2), Known e1)) + (* ASK: | EClosure (n, es) => ? *) + | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e + | EQuery q => (cacheQuery (effs, env, q), state) + | _ => (if effectful effs env exp + then Impure exp + else Cachable (InvalInfo.empty, + fn state => + case cacheExp (env, exp', InvalInfo.empty, state) of + NONE => ((exp', loc), state) + | SOME (exp', state) => ((exp', loc), state)), + state) + end + +fun addCaching file = + let + val effs = effectfulDecls file + fun doTopLevelExp env exp state = runSubexp (cacheTree effs ((env, exp), state)) + in + (fileTopLevelMapfoldB doTopLevelExp + file + {tableToIndices = SIMM.empty, + indexToInvalInfo = IM.empty, + ffiInfo = [], + index = 0}, + effs) + end + + +(************) +(* Flushing *) +(************) + +structure Invalidations = struct + + val loc = dummyLoc + + val optionAtomExpToExp = + fn NONE => (ENone stringTyp, loc) + | SOME e => (ESome (stringTyp, + (case e of + DmlRel n => ERel n + | Prim p => EPrim p + (* TODO: make new type containing only these two. *) + | _ => raise Fail "Sqlcache: Invalidations.optionAtomExpToExp", + loc)), + loc) + + fun eqsToInvalidation numArgs eqs = + List.tabulate (numArgs, (fn n => IM.find (eqs, n))) + + (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here + represents unknown, which means a wider invalidation. *) + val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = + fn ([], []) => true + | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys) + | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of + EQUAL => madeRedundantBy (xs, ys) + | _ => false) + | _ => false + + fun invalidations ((invalInfo, numArgs), dml) = + let + val query = InvalInfo.query invalInfo + in + (map (map optionAtomExpToExp) + o removeRedundant madeRedundantBy + o map (eqsToInvalidation numArgs) + o conflictMaps) + (pairToFormulas (query, dml)) + end + +end + +val invalidations = Invalidations.invalidations + +fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state), effs) = + let + val flushes = List.concat + o map (fn (i, argss) => map (fn args => flush (i, args)) argss) + val doExp = + fn dmlExp as EDml (dmlText, failureMode) => + let + val inval = + case Sql.parse Sql.dml dmlText of + SOME dmlParsed => + SOME (map (fn i => (case IM.find (indexToInvalInfo, i) of + SOME invalInfo => + (i, invalidations (invalInfo, dmlParsed)) + (* TODO: fail more gracefully. *) + (* This probably means invalidating everything.... *) + | NONE => raise Fail "Sqlcache: addFlushing (a)")) + (SIMM.findList (tableToIndices, tableOfDml dmlParsed))) + | NONE => NONE + in + case inval of + (* TODO: fail more gracefully. *) + NONE => raise Fail "Sqlcache: addFlushing (b)" + | SOME invs => sequence (flushes invs @ [dmlExp]) + end + | e' => e' + val file = fileMap doExp file + + in + ffiInfoRef := ffiInfo; + file + end + + +(***********) +(* Locking *) +(***********) + +(* TODO: do this less evilly by not relying on specific FFI names, please? *) +fun locksNeeded (lockMap : {store : IIMM.multimap, flush : IIMM.multimap}) = + MonoUtil.Exp.fold + {typ = #2, + exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) => + (case Int.fromString (String.extract (x, 5, NONE)) of + NONE => state + | SOME index => + if String.isPrefix "flush" x + then {store = store, flush = IS.add (flush, index)} + else if String.isPrefix "store" x + then {store = IS.add (store, index), flush = flush} + else state) + | (ENamed n, {store, flush}) => + {store = IS.union (store, IIMM.findSet (#store lockMap, n)), + flush = IS.union (flush, IIMM.findSet (#flush lockMap, n))} + | (_, state) => state} + {store = IS.empty, flush = IS.empty} + +fun lockMapOfFile file = + transitiveAnalysis + (fn ((_, name, _, e, _), state) => + let + val locks = locksNeeded state e + in + {store = IIMM.insertSet (#store state, name, #store locks), + flush = IIMM.insertSet (#flush state, name, #flush locks)} + end) + {store = IIMM.empty, flush = IIMM.empty} + file + +fun exports (decls, _) = + List.foldl (fn ((DExport (_, _, n, _, _, _), _), ns) => IS.add (ns, n) + | (_, ns) => ns) + IS.empty + decls + +fun wrapLocks (locks, (exp', loc)) = + case exp' of + EAbs (s, t1, t2, exp) => (EAbs (s, t1, t2, wrapLocks (locks, exp)), loc) + | _ => (List.foldr (fn (l, e') => sequence [lock l, e']) exp' locks, loc) + +fun addLocking file = + let + val lockMap = lockMapOfFile file + fun lockList {store, flush} = + let + val ls = map (fn i => (i, true)) (IS.listItems flush) + @ map (fn i => (i, false)) (IS.listItems (IS.difference (store, flush))) + in + ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls + end + fun locksOfName n = + lockList {flush = IIMM.findSet (#flush lockMap, n), + store = IIMM.findSet (#store lockMap, n)} + val locksOfExp = lockList o locksNeeded lockMap + val expts = exports file + fun doVal (v as (x, n, t, exp, s)) = + if IS.member (expts, n) + then (x, n, t, wrapLocks ((locksOfName n), exp), s) + else v + val doDecl = + fn (DVal v, loc) => (DVal (doVal v), loc) + | (DValRec vs, loc) => (DValRec (map doVal vs), loc) + | (DTask (exp1, exp2), loc) => (DTask (exp1, wrapLocks (locksOfExp exp2, exp2)), loc) + | decl => decl + in + mapFst (map doDecl) file + end + + +(************************) +(* Compiler Entry Point *) +(************************) + +val inlineSql = + let + val doExp = + (* TODO: EQuery, too? *) + (* ASK: should this live in [MonoOpt]? *) + fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => + let + val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases + in + ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) + end + | e => e + in + fileMap doExp + end + +fun insertAfterDatatypes ((decls, sideInfo), newDecls) = + let + val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls + in + (datatypes @ newDecls @ others, sideInfo) + end + +val go' = addLocking o addFlushing o addCaching o simplifySql o inlineSql + +fun go file = + let + (* TODO: do something nicer than [Sql] being in one of two modes. *) + val () = (resetFfiInfo (); Sql.sqlcacheMode := true) + val file = go' file + (* Important that this happens after [MonoFooify.urlify] calls! *) + val fmDecls = MonoFooify.getNewFmDecls () + val () = Sql.sqlcacheMode := false + in + insertAfterDatatypes (file, rev fmDecls) + end + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/toy_cache.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,207 @@ +structure ToyCache : sig + val cache : Cache.cache +end = struct + + +(* Mono *) + +open Mono + +val dummyLoc = ErrorMsg.dummySpan +val stringTyp = (TFfi ("Basis", "string"), dummyLoc) +val optionStringTyp = (TOption stringTyp, dummyLoc) +fun withTyp typ = map (fn exp => (exp, typ)) + +fun ffiAppCache' (func, index, argTyps) = + EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps) + +fun check (index, keys) = + ffiAppCache' ("check", index, withTyp stringTyp keys) + +fun store (index, keys, value) = + ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys) + +fun flush (index, keys) = + ffiAppCache' ("flush", index, withTyp optionStringTyp keys) + +fun lock (index, keys) = + raise Fail "ToyCache doesn't yet implement lock" + + +(* Cjr *) + +open Print +open Print.PD + +fun setupQuery {index, params} = + let + + val i = Int.toString index + + fun paramRepeat itemi sep = + let + fun f n = + if n < 0 then "" + else if n = 0 then itemi (Int.toString 0) + else f (n-1) ^ sep ^ itemi (Int.toString n) + in + f (params - 1) + end + + fun paramRepeatInit itemi sep = + if params = 0 then "" else sep ^ paramRepeat itemi sep + + val args = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", " + + val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" + ^ p ^ " = NULL;") + "\n" + + val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p + ^ " = strdup(p" ^ p ^ ");") + "\n" + + val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") + "\n" + + val eqs = paramRepeatInit (fn p => "strcmp(param" ^ i ^ "_" ^ p + ^ ", p" ^ p ^ ")") + " || " + + (* Using [!=] instead of [==] to mimic [strcmp]. *) + val eqsNull = paramRepeatInit (fn p => "(p" ^ p ^ " == NULL || " + ^ "!strcmp(param" ^ i ^ "_" + ^ p ^ ", p" ^ p ^ "))") + " && " + + in + Print.box + [string "static char *cacheQuery", + string i, + string " = NULL;", + newline, + string "static char *cacheWrite", + string i, + string " = NULL;", + newline, + string decls, + newline, + string "static uw_Basis_string uw_Sqlcache_check", + string i, + string "(uw_context ctx", + string args, + string ") {", + newline, + string "if (cacheWrite", + string i, + (* ASK: is returning the pointer okay? Should we duplicate? *) + string " == NULL", + string eqs, + string ") {", + newline, + string "puts(\"SQLCACHE: miss ", + string i, + string ".\");", + newline, + string "uw_recordingStart(ctx);", + newline, + string "return NULL;", + newline, + string "} else {", + newline, + string "puts(\"SQLCACHE: hit ", + string i, + string ".\");", + newline, + string " if (cacheWrite", + string i, + string " != NULL) { uw_write(ctx, cacheWrite", + string i, + string "); }", + newline, + string "return cacheQuery", + string i, + string ";", + newline, + string "} };", + newline, + string "static uw_unit uw_Sqlcache_store", + string i, + string "(uw_context ctx, uw_Basis_string s", + string args, + string ") {", + newline, + string "free(cacheQuery", + string i, + string "); free(cacheWrite", + string i, + string ");", + newline, + string frees, + newline, + string "cacheQuery", + string i, + string " = strdup(s); cacheWrite", + string i, + string " = uw_recordingRead(ctx);", + newline, + string sets, + newline, + string "puts(\"SQLCACHE: store ", + string i, + string ".\");", + newline, + string "return uw_unit_v;", + newline, + string "};", + newline, + string "static uw_unit uw_Sqlcache_flush", + string i, + string "(uw_context ctx", + string args, + string ") {", + newline, + string "if (cacheQuery", + string i, + string " != NULL", + string eqsNull, + string ") {", + newline, + string "free(cacheQuery", + string i, + string ");", + newline, + string "cacheQuery", + string i, + string " = NULL;", + newline, + string "free(cacheWrite", + string i, + string ");", + newline, + string "cacheWrite", + string i, + string " = NULL;", + newline, + string "puts(\"SQLCACHE: flush ", + string i, + string ".\");}", + newline, + string "else { puts(\"SQLCACHE: keep ", + string i, + string ".\"); } return uw_unit_v;", + newline, + string "};", + newline, + newline] + end + +val setupGlobal = string "/* No global setup for toy cache. */" + + +(* Bundled up. *) + +val cache = {check = check, store = store, flush = flush, lock = lock, + setupQuery = setupQuery, setupGlobal = setupGlobal} + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/triple_key_fn.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,15 @@ +functor TripleKeyFn (structure I : ORD_KEY + structure J : ORD_KEY + structure K : ORD_KEY) + : ORD_KEY where type ord_key = I.ord_key * J.ord_key * K.ord_key = struct + +type ord_key = I.ord_key * J.ord_key * K.ord_key + +fun compare ((i1, j1, k1), (i2, j2, k2)) = + case I.compare (i1, i2) of + EQUAL => (case J.compare (j1, j2) of + EQUAL => K.compare (k1, k2) + | ord => ord) + | ord => ord + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/union_find_fn.sml Sun Dec 20 14:18:52 2015 -0500 @@ -0,0 +1,58 @@ +functor UnionFindFn(K : ORD_KEY) :> sig + type unionFind + val empty : unionFind + val union : unionFind * K.ord_key * K.ord_key -> unionFind + val union' : (K.ord_key * K.ord_key) * unionFind -> unionFind + val together : unionFind * K.ord_key * K.ord_key -> bool + val classes : unionFind -> K.ord_key list list +end = struct + +structure M = BinaryMapFn(K) +structure S = BinarySetFn(K) + +datatype entry = + Set of S.set + | Pointer of K.ord_key + +(* First map is the union-find tree, second stores equivalence classes. *) +type unionFind = entry M.map ref * S.set M.map + +val empty : unionFind = (ref M.empty, M.empty) + +fun findPair (uf, x) = + case M.find (!uf, x) of + NONE => (S.singleton x, x) + | SOME (Set set) => (set, x) + | SOME (Pointer parent) => + let + val (set, rep) = findPair (uf, parent) + in + uf := M.insert (!uf, x, Pointer rep); + (set, rep) + end + +fun find ((uf, _), x) = (S.listItems o #1 o findPair) (uf, x) + +fun classes (_, cs) = (map S.listItems o M.listItems) cs + +fun together ((uf, _), x, y) = case K.compare (#2 (findPair (uf, x)), #2 (findPair (uf, y))) of + EQUAL => true + | _ => false + +fun union ((uf, cs), x, y) = + let + val (xSet, xRep) = findPair (uf, x) + val (ySet, yRep) = findPair (uf, y) + val xySet = S.union (xSet, ySet) + in + (ref (M.insert (M.insert (!uf, yRep, Pointer xRep), + xRep, Set xySet)), + M.insert (case M.find (cs, yRep) of + NONE => cs + | SOME _ => #1 (M.remove (cs, yRep)), + xRep, xySet)) + end + +fun union' ((x, y), uf) = union (uf, x, y) + +end
--- a/src/urweb.lex Sun Dec 20 13:41:35 2015 -0500 +++ b/src/urweb.lex Sun Dec 20 14:18:52 2015 -0500 @@ -18,7 +18,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -50,7 +50,7 @@ else (); commentLevel := !commentLevel + 1) - + fun exitComment () = (ignore (commentLevel := !commentLevel - 1); if !commentLevel = 0 then @@ -58,15 +58,15 @@ else ()) - fun eof () = - let + fun eof () = + let val pos = ErrorMsg.lastLineStart () in if !commentLevel > 0 then ErrorMsg.errorAt' (!commentPos, !commentPos) "Unterminated comment" else (); - Tokens.EOF (pos, pos) + Tokens.EOF (pos, pos) end end @@ -301,7 +301,7 @@ Tokens.XML_END (yypos, yypos + size yytext)) else Tokens.END_TAG (id, yypos, yypos + size yytext) - | _ => + | _ => Tokens.END_TAG (id, yypos, yypos + size yytext) end);