Mercurial > urweb

comparison src/iflow.sml @ 1852:3c93e91e97da

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Get Iflow working again
author Adam Chlipala <adam@chlipala.net>
date Sun, 21 Apr 2013 13:03:20 -0400
parents c1e3805e604e
children 98895243b5b6
comparison
equal deleted inserted replaced
1851:1239ba1a1671 1852:3c93e91e97da
1 (* Copyright (c) 2010, Adam Chlipala 1 (* Copyright (c) 2010, 2013, Adam Chlipala
2 * All rights reserved. 2 * All rights reserved.
3 * 3 *
4 * Redistribution and use in source and binary forms, with or without 4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met: 5 * modification, are permitted provided that the following conditions are met:
6 * 6 *
1247 Cont : queryMode 1247 Cont : queryMode
1248 } 1248 }
1249 1249
1250 fun doQuery (arg : 'a doQuery) (e as (_, loc)) = 1250 fun doQuery (arg : 'a doQuery) (e as (_, loc)) =
1251 let 1251 let
1252 fun default () = ErrorMsg.errorAt loc "Information flow checker can't parse SQL query" 1252 fun default () = (ErrorMsg.errorAt loc "Information flow checker can't parse SQL query";
1253 Print.preface ("Query", MonoPrint.p_exp MonoEnv.empty e))
1253 in 1254 in
1254 case parse query e of 1255 case parse query e of
1255 NONE => default () 1256 NONE => default ()
1256 | SOME q => 1257 | SOME q =>
1257 let 1258 let
1793 | ESpawn _ => default () 1794 | ESpawn _ => default ()
1794 end 1795 end
1795 1796
1796 datatype var_source = Input of int | SubInput of int | Unknown 1797 datatype var_source = Input of int | SubInput of int | Unknown
1797 1798
1799 structure U = MonoUtil
1800
1801 fun mliftExpInExp by =
1802 U.Exp.mapB {typ = fn t => t,
1803 exp = fn bound => fn e =>
1804 case e of
1805 ERel xn =>
1806 if xn < bound then
1807 e
1808 else
1809 ERel (xn + by)
1810 | _ => e,
1811 bind = fn (bound, U.Exp.RelE _) => bound + 1
1812 | (bound, _) => bound}
1813
1814 fun nameSubexps k (e : Mono.exp) =
1815 let
1816 fun numParams (e : Mono.exp) =
1817 case #1 e of
1818 EStrcat (e1, e2) => numParams e1 + numParams e2
1819 | EPrim (Prim.String _) => 0
1820 | _ => 1
1821
1822 val nps = numParams e
1823
1824 fun getParams (e : Mono.exp) x =
1825 case #1 e of
1826 EStrcat (e1, e2) =>
1827 let
1828 val (ps1, e1') = getParams e1 x
1829 val (ps2, e2') = getParams e2 (x - length ps1)
1830 in
1831 (ps2 @ ps1, (EStrcat (e1', e2'), #2 e))
1832 end
1833 | EPrim (Prim.String _) => ([], e)
1834 | _ =>
1835 let
1836 val (e', k) =
1837 case #1 e of
1838 EFfiApp (m, f, [(e', t)]) =>
1839 if Settings.isEffectful (m, f) orelse Settings.isBenignEffectful (m, f) then
1840 (e, fn x => x)
1841 else
1842 (e', fn e' => (EFfiApp (m, f, [(e', t)]), #2 e))
1843 | ECase (e', ps as
1844 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
1845 (EPrim (Prim.String "TRUE"), _)),
1846 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
1847 (EPrim (Prim.String "FALSE"), _))], q) =>
1848 (e', fn e' => (ECase (e', ps, q), #2 e))
1849 | _ => (e, fn x => x)
1850 in
1851 ([e'], k (ERel x, #2 e))
1852 end
1853
1854 val (ps, e') = getParams e (nps - 1)
1855
1856 val string = (TFfi ("Basis", "string"), #2 e)
1857
1858 val (e', _) = foldl (fn (p, (e', liftBy)) =>
1859 ((ELet ("p" ^ Int.toString liftBy,
1860 string,
1861 mliftExpInExp liftBy 0 p,
1862 e'), #2 e), liftBy - 1)) (k (nps, e'), nps - 1) ps
1863 in
1864 #1 e'
1865 end
1866
1867 val namer = MonoUtil.File.map {typ = fn t => t,
1868 exp = fn e =>
1869 case e of
1870 EDml (e, fm) =>
1871 nameSubexps (fn (_, e') => (EDml (e', fm), #2 e)) e
1872 | EQuery {exps, tables, state, query, body, initial} =>
1873 nameSubexps (fn (liftBy, e') =>
1874 (EQuery {exps = exps,
1875 tables = tables,
1876 state = state,
1877 query = e',
1878 body = mliftExpInExp liftBy 2 body,
1879 initial = mliftExpInExp liftBy 0 initial},
1880 #2 query)) query
1881 | _ => e,
1882 decl = fn d => d}
1883
1798 fun check (file : file) = 1884 fun check (file : file) =
1799 let 1885 let
1800 val () = (St.reset (); 1886 val () = (St.reset ();
1801 rfuns := IM.empty) 1887 rfuns := IM.empty)
1802 1888
1889 (*val () = Print.preface ("FilePre", MonoPrint.p_file MonoEnv.empty file)*)
1803 val file = MonoReduce.reduce file 1890 val file = MonoReduce.reduce file
1804 val file = MonoOpt.optimize file 1891 val file = MonoOpt.optimize file
1805 val file = Fuse.fuse file 1892 val file = Fuse.fuse file
1806 val file = MonoOpt.optimize file 1893 val file = MonoOpt.optimize file
1807 val file = MonoShake.shake file 1894 val file = MonoShake.shake file
1895 val file = namer file
1808 (*val () = Print.preface ("File", MonoPrint.p_file MonoEnv.empty file)*) 1896 (*val () = Print.preface ("File", MonoPrint.p_file MonoEnv.empty file)*)
1809 1897
1810 val exptd = foldl (fn ((d, _), exptd) => 1898 val exptd = foldl (fn ((d, _), exptd) =>
1811 case d of 1899 case d of
1812 DExport (_, _, n, _, _, _) => IS.add (exptd, n) 1900 DExport (_, _, n, _, _, _) => IS.add (exptd, n)
2075 end 2163 end
2076 2164
2077 val check = fn file => 2165 val check = fn file =>
2078 let 2166 let
2079 val oldInline = Settings.getMonoInline () 2167 val oldInline = Settings.getMonoInline ()
2168 val oldFull = !MonoReduce.fullMode
2080 in 2169 in
2081 (Settings.setMonoInline (case Int.maxInt of 2170 (Settings.setMonoInline (case Int.maxInt of
2082 NONE => 1000000 2171 NONE => 1000000
2083 | SOME n => n); 2172 | SOME n => n);
2173 MonoReduce.fullMode := true;
2084 check file; 2174 check file;
2085 Settings.setMonoInline oldInline) 2175 Settings.setMonoInline oldInline)
2086 handle ex => (Settings.setMonoInline oldInline; 2176 handle ex => (Settings.setMonoInline oldInline;
2177 MonoReduce.fullMode := oldFull;
2087 raise ex) 2178 raise ex)
2088 end 2179 end
2089 2180
2090 end 2181 end