diff --git a/haste-compiler.cabal b/haste-compiler.cabal --- a/haste-compiler.cabal +++ b/haste-compiler.cabal @@ -1,5 +1,5 @@ Name: haste-compiler -Version: 0.2.1 +Version: 0.2.2 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler @@ -29,6 +29,7 @@ md5.js array.js pointers.js + unicode.js debug.js Executable haste-boot diff --git a/lib/Integer.js b/lib/Integer.js --- a/lib/Integer.js +++ b/lib/Integer.js @@ -77,7 +77,7 @@ result = I_add(I_mul(result, power), I_fromNumber(value)); } else { result = I_mul(result, radixToPower); - result = I_add(add, I_fromNumber(value)); + result = I_add(result, I_fromNumber(value)); } } return result; @@ -324,11 +324,11 @@ } var I_quotRem = function(self, other) { - return [1, I_quot(self, other), I_rem(self, other)]; + return [0, I_quot(self, other), I_rem(self, other)]; } var I_divMod = function(self, other) { - return [1, I_div(self, other), I_mod(self, other)]; + return [0, I_div(self, other), I_mod(self, other)]; } var I_quot = function(self, other) { @@ -468,7 +468,7 @@ if(dec[1] < 0) { mantissa = I_negate(mantissa); } - return [1, dec[4], mantissa]; + return [0, dec[4], mantissa]; } var I_toString = function(self) { diff --git a/lib/MVar.js b/lib/MVar.js --- a/lib/MVar.js +++ b/lib/MVar.js @@ -9,11 +9,11 @@ function tryTakeMVar(mv) { if(mv.empty) { - return [1, 0, undefined]; + return [0, 0, undefined]; } else { mv.empty = true; mv.x = null; - return [1, 1, mv.x]; + return [0, 1, mv.x]; } } diff --git a/lib/rts.js b/lib/rts.js --- a/lib/rts.js +++ b/lib/rts.js @@ -8,10 +8,6 @@ */ function T(f) { - return new Thunk(f); -} - -function Thunk(f) { this.f = f; } @@ -22,7 +18,7 @@ function) is then applied to the remaining arguments. */ function A(f, args) { - f = f instanceof Thunk ? E(f) : f; + f = f instanceof T ? E(f) : f; // Closure does some funny stuff with functions that occasionally // results in non-functions getting applied, so we have to deal with // it. @@ -52,7 +48,7 @@ If the "thunk" we get isn't actually a thunk, just return it. */ function E(t) { - if(t instanceof Thunk) { + if(t instanceof T) { if(t.f) { t.x = t.f(); t.f = 0; @@ -74,7 +70,7 @@ } function quotRemI(a, b) { - return [1, (a-a%b)/b, a%b]; + return [0, (a-a%b)/b, a%b]; } // 32 bit integer multiplication, with correct overflow behavior @@ -90,12 +86,12 @@ function addC(a, b) { var x = a+b; - return [1, x & 0xffffffff, x > 0x7fffffff]; + return [0, x & 0xffffffff, x > 0x7fffffff]; } function subC(a, b) { var x = a-b; - return [1, x & 0xffffffff, x < -2147483648]; + return [0, x & 0xffffffff, x < -2147483648]; } function sinh (arg) { @@ -126,7 +122,7 @@ } else { man |= (1 << 23); } - return [1, sign*man, exp]; + return [0, sign*man, exp]; } function decodeDouble(x) { @@ -140,7 +136,7 @@ } else { manHigh |= (1 << 20); } - return [1, sign, manHigh, manLow, exp]; + return [0, sign, manHigh, manLow, exp]; } function err(str) { @@ -150,12 +146,12 @@ /* unpackCString# NOTE: update constructor tags if the code generator starts munging them. */ -function unCStr(str) {return unAppCStr(str, [1]);} +function unCStr(str) {return unAppCStr(str, [0]);} function unFoldrCStr(str, f, z) { var acc = z; for(var i = str.length-1; i >= 0; --i) { - acc = A(f, [[1, str.charCodeAt(i)], acc]); + acc = A(f, [[0, str.charCodeAt(i)], acc]); } return acc; } @@ -165,7 +161,7 @@ if(i >= str.length) { return E(chrs); } else { - return [2,[1,str.charCodeAt(i)],T(function() { + return [1,[0,str.charCodeAt(i)],new T(function() { return unAppCStr(str,chrs,i+1); })]; } @@ -179,10 +175,10 @@ function toJSStr(hsstr) { var s = ''; - for(var str = E(hsstr); str[0] == 2; str = E(str[2])) { + for(var str = E(hsstr); str[0] == 1; str = E(str[2])) { s += String.fromCharCode(E(str[1])[1]); } - return [1,s]; + return [0,s]; } // newMutVar @@ -227,15 +223,12 @@ } function strOrd(a, b) { - var ord; if(a < b) { - ord = [1]; + return [0]; } else if(a == b) { - ord = [2]; - } else { - ord = [3]; + return [1]; } - return ord; + return [2]; } function jsCatch(act, handler) { @@ -267,9 +260,9 @@ */ function dataToTag(x) { if(x instanceof Array) { - return x[0]-1; + return x[0]; } else { - return x-1; + return x; } } diff --git a/lib/stdlib.js b/lib/stdlib.js --- a/lib/stdlib.js +++ b/lib/stdlib.js @@ -45,7 +45,7 @@ if(evt == 'change' && elem.type.toLowerCase() == 'text') { setCB(elem, 'keyup', function(k) { if(k == '\n'.charCodeAt(0)) { - A(cb,[[1,k.keyCode],0]); + A(cb,[[0,k.keyCode],0]); } }); } @@ -56,12 +56,12 @@ case 'dblclick': case 'mouseup': case 'mousedown': - fun = function(x) {A(cb,[[1,x.button],0]);}; + fun = function(x) {A(cb,[[0,x.button],0]);}; break; case 'keypress': case 'keyup': case 'keydown': - fun = function(x) {A(cb,[[1,x.keyCode],0]);}; + fun = function(x) {A(cb,[[0,x.keyCode],0]);}; break; default: fun = function() {A(cb,[0]);}; @@ -130,9 +130,9 @@ function jsFind(elem) { var e = document.getElementById(elem) if(e) { - return [2,[1,e]]; + return [1,[0,e]]; } - return [1]; + return [0]; } function jsCreateElem(tag) { @@ -143,29 +143,29 @@ elem = elem.previousSibling; while(elem) { if(typeof elem.tagName != 'undefined') { - return [2,[1,elem]]; + return [1,[0,elem]]; } elem = elem.previousSibling; } - return [1]; + return [0]; } function jsGetLastChild(elem) { var len = elem.childNodes.length; for(var i = len-1; i >= 0; --i) { if(typeof elem.childNodes[i].tagName != 'undefined') { - return [2,[1,elem.childNodes[i]]]; + return [1,[0,elem.childNodes[i]]]; } } - return [1]; + return [0]; } function jsGetChildren(elem) { - var children = [1]; + var children = [0]; var len = elem.childNodes.length; for(var i = len-1; i >= 0; --i) { if(typeof elem.childNodes[i].tagName != 'undefined') { - children = [2, [1,elem.childNodes[i]], children]; + children = [1, [0,elem.childNodes[i]], children]; } } return children; @@ -174,7 +174,7 @@ function jsSetChildren(elem, children) { children = E(children); jsClearChildren(elem, 0); - while(children[0] === 2) { + while(children[0] === 1) { elem.appendChild(E(E(children[1])[1])); children = E(children[2]); } @@ -218,24 +218,24 @@ var js = JSON.parse(str); var hs = toHS(js); } catch(_) { - return [1]; + return [0]; } - return [2,hs]; + return [1,hs]; } function toHS(obj) { switch(typeof obj) { case 'number': - return [1, [1, jsRead(obj)]]; + return [0, [0, jsRead(obj)]]; case 'string': - return [2, [1, obj]]; + return [1, [0, obj]]; break; case 'boolean': - return [3, obj]; // Booleans are special wrt constructor tags! + return [2, obj]; // Booleans are special wrt constructor tags! break; case 'object': if(obj instanceof Array) { - return [4, arr2lst(obj, 0)]; + return [3, arr2lst(obj, 0)]; } else { // Object type but not array - it's a dictionary. // The RFC doesn't say anything about the ordering of keys, but @@ -247,20 +247,20 @@ for(var k in obj) { ks.unshift(k); } - var xs = [1]; + var xs = [0]; for(var i in ks) { - xs = [2, [1, [1,ks[i]], toHS(obj[ks[i]])], xs]; + xs = [1, [0, [0,ks[i]], toHS(obj[ks[i]])], xs]; } - return [5, xs]; + return [4, xs]; } } } function arr2lst(arr, elem) { if(elem >= arr.length) { - return [1]; + return [0]; } - return [2, toHS(arr[elem]), T(function() {return arr2lst(arr,elem+1);})] + return [1, toHS(arr[elem]), new T(function() {return arr2lst(arr,elem+1);})] } function ajaxReq(method, url, async, postdata, cb) { @@ -270,19 +270,11 @@ xhr.onreadystatechange = function() { if(xhr.readyState == 4) { if(xhr.status == 200) { - A(cb,[[2,[1,xhr.responseText]],0]); + A(cb,[[1,[0,xhr.responseText]],0]); } else { - A(cb,[[1],0]); // Nothing + A(cb,[[0],0]); // Nothing } } } xhr.send(postdata); -} - -function u_towlower(charCode) { - return String.fromCharCode(charCode).toLowerCase().charCodeAt(0); -} - -function u_towupper(charCode) { - return String.fromCharCode(charCode).toUpperCase().charCodeAt(0); } diff --git a/lib/unicode.js b/lib/unicode.js new file mode 100644 --- /dev/null +++ b/lib/unicode.js @@ -0,0 +1,56 @@ +function withChar(f, charCode) { + return f(String.fromCharCode(charCode)).charCodeAt(0); +} + +function u_towlower(charCode) { + return withChar(function(c) {return c.toLowerCase()}, charCode); +} + +function u_towupper(charCode) { + return withChar(function(c) {return c.toUpperCase()}, charCode); +} + +var u_towtitle = u_towupper; + +function u_iswupper(charCode) { + var c = String.fromCharCode(charCode); + return isNaN(c*1) && c == c.toUpperCase(); +} + +function u_iswlower(charCode) { + var c = String.fromCharCode(charCode); + return isNaN(c*1) && c == c.toLowerCase(); +} + +function u_iswdigit(charCode) { + return charCode >= 48 && charCode <= 57; +} + +function u_iswcntrl(charCode) { + return charCode <= 0x1f || charCode == 0x7f; +} + +function u_iswspace(charCode) { + var c = String.fromCharCode(charCode); + return c.replace(/\s/g,'') != c; +} + +function u_iswalpha(charCode) { + var c = String.fromCharCode(charCode); + return c.replace(__hs_alphare, '') != c; +} + +function u_iswalnum(charCode) { + return u_iswdigit(charCode) || u_iswalpha(charCode); +} + +function u_iswprint(charCode) { + return !u_iswcntrl(charCode); +} + +function u_gencat(c) { + throw 'u_gencat is not supported; submit a patch if you want it to be'; +} + +// Regex that matches any alphabetic character in any language. Horrible thing. +var __hs_alphare = /[\u0041-\u005A\u0061-\u007A\u00AA\u00B5\u00BA\u00C0-\u00D6\u00D8-\u00F6\u00F8-\u02C1\u02C6-\u02D1\u02E0-\u02E4\u02EC\u02EE\u0370-\u0374\u0376\u0377\u037A-\u037D\u0386\u0388-\u038A\u038C\u038E-\u03A1\u03A3-\u03F5\u03F7-\u0481\u048A-\u0527\u0531-\u0556\u0559\u0561-\u0587\u05D0-\u05EA\u05F0-\u05F2\u0620-\u064A\u066E\u066F\u0671-\u06D3\u06D5\u06E5\u06E6\u06EE\u06EF\u06FA-\u06FC\u06FF\u0710\u0712-\u072F\u074D-\u07A5\u07B1\u07CA-\u07EA\u07F4\u07F5\u07FA\u0800-\u0815\u081A\u0824\u0828\u0840-\u0858\u08A0\u08A2-\u08AC\u0904-\u0939\u093D\u0950\u0958-\u0961\u0971-\u0977\u0979-\u097F\u0985-\u098C\u098F\u0990\u0993-\u09A8\u09AA-\u09B0\u09B2\u09B6-\u09B9\u09BD\u09CE\u09DC\u09DD\u09DF-\u09E1\u09F0\u09F1\u0A05-\u0A0A\u0A0F\u0A10\u0A13-\u0A28\u0A2A-\u0A30\u0A32\u0A33\u0A35\u0A36\u0A38\u0A39\u0A59-\u0A5C\u0A5E\u0A72-\u0A74\u0A85-\u0A8D\u0A8F-\u0A91\u0A93-\u0AA8\u0AAA-\u0AB0\u0AB2\u0AB3\u0AB5-\u0AB9\u0ABD\u0AD0\u0AE0\u0AE1\u0B05-\u0B0C\u0B0F\u0B10\u0B13-\u0B28\u0B2A-\u0B30\u0B32\u0B33\u0B35-\u0B39\u0B3D\u0B5C\u0B5D\u0B5F-\u0B61\u0B71\u0B83\u0B85-\u0B8A\u0B8E-\u0B90\u0B92-\u0B95\u0B99\u0B9A\u0B9C\u0B9E\u0B9F\u0BA3\u0BA4\u0BA8-\u0BAA\u0BAE-\u0BB9\u0BD0\u0C05-\u0C0C\u0C0E-\u0C10\u0C12-\u0C28\u0C2A-\u0C33\u0C35-\u0C39\u0C3D\u0C58\u0C59\u0C60\u0C61\u0C85-\u0C8C\u0C8E-\u0C90\u0C92-\u0CA8\u0CAA-\u0CB3\u0CB5-\u0CB9\u0CBD\u0CDE\u0CE0\u0CE1\u0CF1\u0CF2\u0D05-\u0D0C\u0D0E-\u0D10\u0D12-\u0D3A\u0D3D\u0D4E\u0D60\u0D61\u0D7A-\u0D7F\u0D85-\u0D96\u0D9A-\u0DB1\u0DB3-\u0DBB\u0DBD\u0DC0-\u0DC6\u0E01-\u0E30\u0E32\u0E33\u0E40-\u0E46\u0E81\u0E82\u0E84\u0E87\u0E88\u0E8A\u0E8D\u0E94-\u0E97\u0E99-\u0E9F\u0EA1-\u0EA3\u0EA5\u0EA7\u0EAA\u0EAB\u0EAD-\u0EB0\u0EB2\u0EB3\u0EBD\u0EC0-\u0EC4\u0EC6\u0EDC-\u0EDF\u0F00\u0F40-\u0F47\u0F49-\u0F6C\u0F88-\u0F8C\u1000-\u102A\u103F\u1050-\u1055\u105A-\u105D\u1061\u1065\u1066\u106E-\u1070\u1075-\u1081\u108E\u10A0-\u10C5\u10C7\u10CD\u10D0-\u10FA\u10FC-\u1248\u124A-\u124D\u1250-\u1256\u1258\u125A-\u125D\u1260-\u1288\u128A-\u128D\u1290-\u12B0\u12B2-\u12B5\u12B8-\u12BE\u12C0\u12C2-\u12C5\u12C8-\u12D6\u12D8-\u1310\u1312-\u1315\u1318-\u135A\u1380-\u138F\u13A0-\u13F4\u1401-\u166C\u166F-\u167F\u1681-\u169A\u16A0-\u16EA\u1700-\u170C\u170E-\u1711\u1720-\u1731\u1740-\u1751\u1760-\u176C\u176E-\u1770\u1780-\u17B3\u17D7\u17DC\u1820-\u1877\u1880-\u18A8\u18AA\u18B0-\u18F5\u1900-\u191C\u1950-\u196D\u1970-\u1974\u1980-\u19AB\u19C1-\u19C7\u1A00-\u1A16\u1A20-\u1A54\u1AA7\u1B05-\u1B33\u1B45-\u1B4B\u1B83-\u1BA0\u1BAE\u1BAF\u1BBA-\u1BE5\u1C00-\u1C23\u1C4D-\u1C4F\u1C5A-\u1C7D\u1CE9-\u1CEC\u1CEE-\u1CF1\u1CF5\u1CF6\u1D00-\u1DBF\u1E00-\u1F15\u1F18-\u1F1D\u1F20-\u1F45\u1F48-\u1F4D\u1F50-\u1F57\u1F59\u1F5B\u1F5D\u1F5F-\u1F7D\u1F80-\u1FB4\u1FB6-\u1FBC\u1FBE\u1FC2-\u1FC4\u1FC6-\u1FCC\u1FD0-\u1FD3\u1FD6-\u1FDB\u1FE0-\u1FEC\u1FF2-\u1FF4\u1FF6-\u1FFC\u2071\u207F\u2090-\u209C\u2102\u2107\u210A-\u2113\u2115\u2119-\u211D\u2124\u2126\u2128\u212A-\u212D\u212F-\u2139\u213C-\u213F\u2145-\u2149\u214E\u2183\u2184\u2C00-\u2C2E\u2C30-\u2C5E\u2C60-\u2CE4\u2CEB-\u2CEE\u2CF2\u2CF3\u2D00-\u2D25\u2D27\u2D2D\u2D30-\u2D67\u2D6F\u2D80-\u2D96\u2DA0-\u2DA6\u2DA8-\u2DAE\u2DB0-\u2DB6\u2DB8-\u2DBE\u2DC0-\u2DC6\u2DC8-\u2DCE\u2DD0-\u2DD6\u2DD8-\u2DDE\u2E2F\u3005\u3006\u3031-\u3035\u303B\u303C\u3041-\u3096\u309D-\u309F\u30A1-\u30FA\u30FC-\u30FF\u3105-\u312D\u3131-\u318E\u31A0-\u31BA\u31F0-\u31FF\u3400-\u4DB5\u4E00-\u9FCC\uA000-\uA48C\uA4D0-\uA4FD\uA500-\uA60C\uA610-\uA61F\uA62A\uA62B\uA640-\uA66E\uA67F-\uA697\uA6A0-\uA6E5\uA717-\uA71F\uA722-\uA788\uA78B-\uA78E\uA790-\uA793\uA7A0-\uA7AA\uA7F8-\uA801\uA803-\uA805\uA807-\uA80A\uA80C-\uA822\uA840-\uA873\uA882-\uA8B3\uA8F2-\uA8F7\uA8FB\uA90A-\uA925\uA930-\uA946\uA960-\uA97C\uA984-\uA9B2\uA9CF\uAA00-\uAA28\uAA40-\uAA42\uAA44-\uAA4B\uAA60-\uAA76\uAA7A\uAA80-\uAAAF\uAAB1\uAAB5\uAAB6\uAAB9-\uAABD\uAAC0\uAAC2\uAADB-\uAADD\uAAE0-\uAAEA\uAAF2-\uAAF4\uAB01-\uAB06\uAB09-\uAB0E\uAB11-\uAB16\uAB20-\uAB26\uAB28-\uAB2E\uABC0-\uABE2\uAC00-\uD7A3\uD7B0-\uD7C6\uD7CB-\uD7FB\uF900-\uFA6D\uFA70-\uFAD9\uFB00-\uFB06\uFB13-\uFB17\uFB1D\uFB1F-\uFB28\uFB2A-\uFB36\uFB38-\uFB3C\uFB3E\uFB40\uFB41\uFB43\uFB44\uFB46-\uFBB1\uFBD3-\uFD3D\uFD50-\uFD8F\uFD92-\uFDC7\uFDF0-\uFDFB\uFE70-\uFE74\uFE76-\uFEFC\uFF21-\uFF3A\uFF41-\uFF5A\uFF66-\uFFBE\uFFC2-\uFFC7\uFFCA-\uFFCF\uFFD2-\uFFD7\uFFDA-\uFFDC]/g; diff --git a/src/ArgSpecs.hs b/src/ArgSpecs.hs --- a/src/ArgSpecs.hs +++ b/src/ArgSpecs.hs @@ -20,12 +20,10 @@ info = "Install all compiled modules into the user's jsmod " ++ "library\nrather than linking them together into a JS" ++ "blob."}, - -- The opt-all enabling -O2 thing is handled directly in main! :( ArgSpec { optName = "opt-all", updateCfg = optAllSafe, info = "Enable all safe optimizations. " - ++ "Equivalent to -O2 --opt-whole-program " - ++ "--opt-google-closure."}, + ++ "Equivalent to -O2 --opt-google-closure."}, ArgSpec { optName = "opt-all-unsafe", updateCfg = optAllUnsafe, info = "Enable all safe and unsafe optimizations.\n" @@ -108,7 +106,7 @@ -- | Enable all safe optimizations. optAllSafe :: Config -> [String] -> Config -optAllSafe = updateClosureCfg ||| enableWholeProgramOpts +optAllSafe = updateClosureCfg -- | Set the path to the Closure compiler.jar to use. updateClosureCfg :: Config -> [String] -> Config diff --git a/src/Data/JSTarget/Constructors.hs b/src/Data/JSTarget/Constructors.hs --- a/src/Data/JSTarget/Constructors.hs +++ b/src/Data/JSTarget/Constructors.hs @@ -84,7 +84,26 @@ -- | Create a thunk. thunk :: AST Stm -> AST Exp -thunk stm = callForeign "T" [Fun Nothing [] <$> stm] +thunk stm@(AST s js) = + case s of + (Return ex) | not $ evaluates ex -> + AST ex js + _ -> + callForeign "new T" [Fun Nothing [] <$> stm] + +-- | Returns True if the given expression causes evaluation by appearing +-- outside a closure, otherwise False. +evaluates :: Exp -> Bool +evaluates (Var _) = False +evaluates (Lit _) = False +evaluates (Not ex) = evaluates ex +evaluates (BinOp _ a b) = evaluates a || evaluates b +evaluates (Fun _ _ _) = False +evaluates (Call _ _ _ _) = True +evaluates (Index a b) = evaluates a || evaluates b +evaluates (Arr xs) = any evaluates xs +evaluates (AssignEx a b) = evaluates a || evaluates b +evaluates (IfEx c a b) = evaluates c || evaluates a || evaluates b -- | Evaluate an expression that may or may not be a thunk. eval :: AST Exp -> AST Exp diff --git a/src/Data/JSTarget/Optimize.hs b/src/Data/JSTarget/Optimize.hs --- a/src/Data/JSTarget/Optimize.hs +++ b/src/Data/JSTarget/Optimize.hs @@ -88,7 +88,7 @@ inlineAssigns :: JSTrav ast => Bool -> ast -> TravM ast inlineAssigns blackholeOK ast = do inlinable <- gatherInlinable ast - mapJS (const True) return (inl inlinable) ast + mapJS (const True) inlEx (inl inlinable) ast where varOccurs lhs (Exp (Var lhs')) = lhs == lhs' varOccurs _ _ = False @@ -117,6 +117,11 @@ else do return keep inl _ stm = return stm + + inlEx (Index (Arr xs) (Lit (LNum n))) = + return $ xs !! truncate n + inlEx x = + return x -- | Gather a map of all inlinable symbols; that is, the once that are used -- exactly once. diff --git a/src/Data/JSTarget/Print.hs b/src/Data/JSTarget/Print.hs --- a/src/Data/JSTarget/Print.hs +++ b/src/Data/JSTarget/Print.hs @@ -160,11 +160,11 @@ indent $ pp def line "}" where - neg' c = maybe (Not c) id $ neg c test (Lit (LBool True)) = cond test (Lit (LBool False)) = Not cond test (Lit (LNum 0)) = Not cond test c = BinOp Eq cond c + neg' c = maybe (Not c) id (neg c) prettyCase _ def [] = do pp def prettyCase cond def alts = do @@ -209,9 +209,16 @@ else pp x -- | Normalize an operator expression by shifting parentheses to the left for --- all associative operators. +-- all associative operators and eliminating comparisons with true/false. norm :: Exp -> Exp norm (BinOp op a (BinOp op' b c)) | op == op' && opIsAssoc op = norm (BinOp op (BinOp op a b) c) -norm e = - e +norm (BinOp Eq a (Lit (LBool True))) = norm a +norm (BinOp Eq (Lit (LBool True)) b) = norm b +norm (BinOp Eq a (Lit (LBool False))) = Not (norm a) +norm (BinOp Eq (Lit (LBool False)) b) = Not (norm b) +norm (BinOp Neq a (Lit (LBool True))) = Not (norm a) +norm (BinOp Neq (Lit (LBool True)) b) = Not (norm b) +norm (BinOp Neq a (Lit (LBool False))) = norm a +norm (BinOp Neq (Lit (LBool False)) b) = norm b +norm e = e diff --git a/src/Haste/CodeGen.hs b/src/Haste/CodeGen.hs --- a/src/Haste/CodeGen.hs +++ b/src/Haste/CodeGen.hs @@ -30,7 +30,7 @@ import BasicTypes -- AST stuff import Data.JSTarget as J -import Data.JSTarget.AST (Exp (..), Stm (..), LHS (..), Lit (..)) +import Data.JSTarget.AST (Exp (..), Stm (..), LHS (..)) -- General Haste stuff import Haste.Config import Haste.Monad @@ -116,7 +116,7 @@ _ -> mkCon tag args' stricts' where -- Always inline bools - mkCon l@(AST (Lit (LBool _)) _) _ _ = return l + mkCon l _ _ | isEnumerationDataCon con = return l mkCon tag as ss = return $ array (tag : zipWith evaluate as ss) evaluate arg True = eval arg evaluate arg _ = arg @@ -267,18 +267,10 @@ getTag s = index s (litN 0) cmp = case t of PrimAlt _ -> id - AlgAlt tc -> if tyConIsBoolean tc then id else getTag + AlgAlt tc -> if isEnumerationTyCon tc then id else getTag _ -> getTag - tyConIsBoolean tc = - case (n, m) of - ("Bool", "GHC.Types") -> True - _ -> False - where - n = occNameString $ nameOccName $ tyConName tc - m = moduleNameString $ moduleName $ nameModule $ tyConName tc - -- | Split a list of StgAlts into (default, [rest]). Since all case expressions -- are total, if there is no explicit default branch, the last conditional -- branch is the default one. @@ -400,14 +392,11 @@ -- (constructor, field strictness annotations). genDataCon :: DataCon -> JSGen Config (AST Exp, [Bool]) genDataCon dc = do - let tagexp = genDataConTag dc - tag = astCode tagexp - case tag of - (Lit (LBool _)) -> - return (tagexp, []) - _ -> - return (tagexp, map strict (dataConRepStrictness dc)) + if isEnumerationDataCon dc + then return (tagexp, []) + else return (tagexp, map strict (dataConRepStrictness dc)) where + tagexp = genDataConTag dc strict MarkedStrict = True strict _ = False @@ -423,7 +412,8 @@ case (n, m) of ("True", "GHC.Types") -> lit True ("False", "GHC.Types") -> lit False - _ -> lit (fromIntegral $ dataConTag d :: Double) + _ -> + lit (fromIntegral (dataConTag d - fIRST_TAG) :: Double) -- | Generate literals. genLit :: L.Literal -> JSGen Config (AST Exp) @@ -463,6 +453,10 @@ else return $ call arity f' xs' where arity = arityInfo $ idInfo f + +-- | Does this data constructor create an enumeration type? +isEnumerationDataCon :: DataCon -> Bool +isEnumerationDataCon = isEnumerationTyCon . dataConTyCon -- | Returns True if the given Var is an unboxed tuple with a single element -- after any represenationless elements are discarded. diff --git a/src/Haste/Config.hs b/src/Haste/Config.hs --- a/src/Haste/Config.hs +++ b/src/Haste/Config.hs @@ -16,7 +16,7 @@ stdJSLibs :: [FilePath] stdJSLibs = unsafePerformIO $ mapM getDataFileName [ "rts.js", "stdlib.js", "MVar.js", "StableName.js", "Integer.js", "md5.js", - "array.js", "pointers.js" + "array.js", "pointers.js", "unicode.js" ] debugLib :: FilePath diff --git a/src/Haste/PrimOps.hs b/src/Haste/PrimOps.hs --- a/src/Haste/PrimOps.hs +++ b/src/Haste/PrimOps.hs @@ -210,6 +210,8 @@ NewMutVarOp -> callF "nMV" ReadMutVarOp -> callF "rMV" WriteMutVarOp -> callF "wMV" + SameMutVarOp -> bOp Eq + AtomicModifyMutVarOp -> Right $ callSaturated (xs !! 1) [(xs !! 0)] -- TVars - since there's no parallelism and no preemption, TVars behave -- just like normal IORefs. @@ -219,6 +221,7 @@ SameTVarOp -> bOp Eq -- Pointer ops + ReallyUnsafePtrEqualityOp -> bOp Eq WriteOffAddrOp_Char -> writeOffAddr xs "i8" 1 WriteOffAddrOp_Int -> writeOffAddr xs "i32" 4 WriteOffAddrOp_Int8 -> writeOffAddr xs "i8" 1 @@ -276,7 +279,7 @@ -- Stable pointers - all pointers are stable in JS! MakeStablePtrOp -> Right $ head xs - EqStablePtrOp -> Right $ head xs + EqStablePtrOp -> bOp Eq DeRefStablePtrOp -> Right $ head xs -- Exception masking @@ -286,10 +289,13 @@ MaskStatus -> Right $ litN 0 -- Misc. ops + DelayOp -> Right $ defState SeqOp -> Right $ callForeign "E" [head xs] AtomicallyOp -> Right $ callSaturated (xs !! 0) [] -- Get the data constructor tag from a value. DataToTagOp -> callF "dataToTag" + -- Basically unsafeCoerce :: Int# -> + TagToEnumOp -> Right $ head xs TouchOp -> Right $ defState RaiseOp -> callF "die" RaiseIOOp -> callF "die" diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs --- a/src/Haste/Version.hs +++ b/src/Haste/Version.hs @@ -10,7 +10,7 @@ import Haste.Environment (hasteDir) hasteVersion :: Version -hasteVersion = Version [0, 2, 1] [] +hasteVersion = Version [0, 2, 2] [] ghcVersion :: String ghcVersion = cProjectVersion