diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Anton Ekblad 2012-2013 + +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. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Milan Straka nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/haste-compiler.cabal b/haste-compiler.cabal new file mode 100644 --- /dev/null +++ b/haste-compiler.cabal @@ -0,0 +1,149 @@ +Name: haste-compiler +Version: 0.2 +License: BSD3 +License-File: LICENSE +Synopsis: Haskell To ECMAScript compiler +Description: This package provides a featureful compiler from Haskell to + Javascript. It generates small, fast code, makes use of + standard Haskell libraries, integrates with Cabal, supports + most GHC extensions and works on Windows, Linux and OSX. + Bug reports are highly appreciated. +Category: Javascript, Compiler, Web +Cabal-Version: >= 1.10 +Build-Type: Simple +Author: Anton Ekblad +Maintainer: anton@ekblad.cc +Homepage: http://github.com/valderman/haste-compiler +Bug-reports: http://github.com/valderman/haste-compiler/issues +Stability: Experimental + +Data-Dir: + lib + +Data-Files: + rts.js + stdlib.js + MVar.js + StableName.js + Integer.js + md5.js + array.js + pointers.js + +Executable haste-boot + Main-Is: haste-boot.hs + Other-Modules: + Haste.Version + Haste.Environment + Control.Shell + Hs-Source-Dirs: src + GHC-Options: -Wall -O2 + Build-Depends: + ghc, + base < 5, + directory, + process, + bytestring, + tar, + bzlib, + zip-archive, + filepath, + temporary, + time, + transformers, + network, + HTTP + Default-Language: Haskell98 + +Executable hastec + Hs-Source-Dirs: src + GHC-Options: -Wall -O2 + Build-Depends: + base < 5, + ghc-prim, + ghc >= 7.6, + mtl, + binary, + containers, + data-default, + bytestring >= 0.10.0.0, + filepath, + directory, + array, + ghc-paths, + process, + random, + system-fileio + Main-Is: + Main.hs + Other-Modules: + Args + ArgSpecs + Haste + Haste.Util + Haste.Version + Haste.Environment + Haste.Config + Haste.Monad + Haste.PrimOps + Haste.Module + Haste.Linker + Haste.Builtins + Haste.Errors + Haste.CodeGen + Data.JSTarget + Data.JSTarget.AST + Data.JSTarget.Binary + Data.JSTarget.Constructors + Data.JSTarget.Op + Data.JSTarget.Optimize + Data.JSTarget.PP + Data.JSTarget.Print + Data.JSTarget.Traversal + default-language: Haskell98 + +Executable haste-inst + Main-Is: haste-inst.hs + Hs-Source-Dirs: src + Build-Depends: + base < 5, + filepath, + process, + directory + default-language: Haskell98 + +Executable haste-pkg + Main-Is: haste-pkg.hs + Hs-Source-Dirs: src + Build-Depends: + base < 5, + process, + filepath, + directory + default-language: Haskell98 + +Executable haste-install-his + Main-Is: haste-install-his.hs + Hs-Source-Dirs: src + Build-Depends: + base < 5, + filepath, + directory, + process + default-language: Haskell98 + +Executable haste-copy-pkg + Main-Is: haste-copy-pkg.hs + Other-Modules: + Haste.Environment + Control.Shell + Hs-Source-Dirs: src + Build-Depends: + base < 5, + filepath, + directory, + process, + temporary, + time, + transformers + default-language: Haskell98 diff --git a/lib/Integer.js b/lib/Integer.js new file mode 100644 --- /dev/null +++ b/lib/Integer.js @@ -0,0 +1,506 @@ +var Integer = function(bits, sign) { + this.bits_ = []; + this.sign_ = sign; + + var top = true; + for (var i = bits.length - 1; i >= 0; i--) { + var val = bits[i] | 0; + if (!top || val != sign) { + this.bits_[i] = val; + top = false; + } + } +}; + +Integer.IntCache_ = {}; + +var I_fromInt = function(value) { + if (-128 <= value && value < 128) { + var cachedObj = Integer.IntCache_[value]; + if (cachedObj) { + return cachedObj; + } + } + + var obj = new Integer([value | 0], value < 0 ? -1 : 0); + if (-128 <= value && value < 128) { + Integer.IntCache_[value] = obj; + } + return obj; +}; + +var I_fromNumber = function(value) { + if (isNaN(value) || !isFinite(value)) { + return Integer.ZERO; + } else if (value < 0) { + return I_negate(I_fromNumber(-value)); + } else { + var bits = []; + var pow = 1; + for (var i = 0; value >= pow; i++) { + bits[i] = (value / pow) | 0; + pow *= Integer.TWO_PWR_32_DBL_; + } + return new Integer(bits, 0); + } +}; + +Integer.fromBits = function(bits) { + var high = bits[bits.length - 1]; + return new Integer(bits, high & (1 << 31) ? -1 : 0); +}; + +I_fromString = function(str, opt_radix) { + if (str.length == 0) { + throw Error('number format error: empty string'); + } + + var radix = opt_radix || 10; + if (radix < 2 || 36 < radix) { + throw Error('radix out of range: ' + radix); + } + + if (str.charAt(0) == '-') { + return I_negate(I_fromString(str.substring(1), radix)); + } else if (str.indexOf('-') >= 0) { + throw Error('number format error: interior "-" character'); + } + + var radixToPower = I_fromNumber(Math.pow(radix, 8)); + + var result = Integer.ZERO; + for (var i = 0; i < str.length; i += 8) { + var size = Math.min(8, str.length - i); + var value = parseInt(str.substring(i, i + size), radix); + if (size < 8) { + var power = I_fromNumber(Math.pow(radix, size)); + result = I_add(I_mul(result, power), I_fromNumber(value)); + } else { + result = I_mul(result, radixToPower); + result = I_add(add, I_fromNumber(value)); + } + } + return result; +}; + + +Integer.TWO_PWR_32_DBL_ = (1 << 16) * (1 << 16); +Integer.ZERO = I_fromInt(0); +Integer.ONE = I_fromInt(1); +Integer.TWO_PWR_24_ = I_fromInt(1 << 24); + +var I_toInt = function(self) { + return self.bits_.length > 0 ? self.bits_[0] : self.sign_; +}; + +var I_toWord = function(self) { + return I_toInt(self) >>> 0; +}; + +var I_toNumber = function(self) { + if (isNegative(self)) { + return -I_toNumber(I_negate(self)); + } else { + var val = 0; + var pow = 1; + for (var i = 0; i < self.bits_.length; i++) { + val += getBitsUnsigned(self, i) * pow; + pow *= Integer.TWO_PWR_32_DBL_; + } + return val; + } +}; + +var getBits = function(self, index) { + if (index < 0) { + return 0; + } else if (index < self.bits_.length) { + return self.bits_[index]; + } else { + return self.sign_; + } +}; + +var getBitsUnsigned = function(self, index) { + var val = getBits(self, index); + return val >= 0 ? val : Integer.TWO_PWR_32_DBL_ + val; +}; + +var getSign = function(self) { + return self.sign_; +}; + +var isZero = function(self) { + if (self.sign_ != 0) { + return false; + } + for (var i = 0; i < self.bits_.length; i++) { + if (self.bits_[i] != 0) { + return false; + } + } + return true; +}; + +var isNegative = function(self) { + return self.sign_ == -1; +}; + +var isOdd = function(self) { + return (self.bits_.length == 0) && (self.sign_ == -1) || + (self.bits_.length > 0) && ((self.bits_[0] & 1) != 0); +}; + +var I_equals = function(self, other) { + if (self.sign_ != other.sign_) { + return false; + } + var len = Math.max(self.bits_.length, other.bits_.length); + for (var i = 0; i < len; i++) { + if (getBits(self, i) != getBits(other, i)) { + return false; + } + } + return true; +}; + +var I_notEquals = function(self, other) { + return !I_equals(self, other); +}; + +var greaterThan = function(self, other) { + return I_compare(self, other) > 0; +}; + +var greaterThanOrEqual = function(self, other) { + return I_compare(self, other) >= 0; +}; + +var lessThan = function(self, other) { + return I_compare(self, other) < 0; +}; + +var lessThanOrEqual = function(self, other) { + return I_compare(self, other) <= 0; +}; + +var I_compare = function(self, other) { + var diff = I_sub(self, other); + if (isNegative(diff)) { + return -1; + } else if (isZero(diff)) { + return 0; + } else { + return +1; + } +}; + +var I_compareInt = function(self, other) { + return I_compare(self, I_fromInt(other)); +} + +var shorten = function(self, numBits) { + var arr_index = (numBits - 1) >> 5; + var bit_index = (numBits - 1) % 32; + var bits = []; + for (var i = 0; i < arr_index; i++) { + bits[i] = getBits(self, i); + } + var sigBits = bit_index == 31 ? 0xFFFFFFFF : (1 << (bit_index + 1)) - 1; + var val = getBits(self, arr_index) & sigBits; + if (val & (1 << bit_index)) { + val |= 0xFFFFFFFF - sigBits; + bits[arr_index] = val; + return new Integer(bits, -1); + } else { + bits[arr_index] = val; + return new Integer(bits, 0); + } +}; + +var I_negate = function(self) { + return I_add(not(self), Integer.ONE); +}; + +var I_add = function(self, other) { + var len = Math.max(self.bits_.length, other.bits_.length); + var arr = []; + var carry = 0; + + for (var i = 0; i <= len; i++) { + var a1 = getBits(self, i) >>> 16; + var a0 = getBits(self, i) & 0xFFFF; + + var b1 = getBits(other, i) >>> 16; + var b0 = getBits(other, i) & 0xFFFF; + + var c0 = carry + a0 + b0; + var c1 = (c0 >>> 16) + a1 + b1; + carry = c1 >>> 16; + c0 &= 0xFFFF; + c1 &= 0xFFFF; + arr[i] = (c1 << 16) | c0; + } + return Integer.fromBits(arr); +}; + +var I_sub = function(self, other) { + return I_add(self, I_negate(other)); +}; + +var I_mul = function(self, other) { + if (isZero(self)) { + return Integer.ZERO; + } else if (isZero(other)) { + return Integer.ZERO; + } + + if (isNegative(self)) { + if (isNegative(other)) { + return I_mul(I_negate(self), I_negate(other)); + } else { + return I_negate(I_mul(I_negate(self), other)); + } + } else if (isNegative(other)) { + return I_negate(I_mul(self, I_negate(other))); + } + + if (lessThan(self, Integer.TWO_PWR_24_) && + lessThan(other, Integer.TWO_PWR_24_)) { + return I_fromNumber(I_toNumber(self) * I_toNumber(other)); + } + + var len = self.bits_.length + other.bits_.length; + var arr = []; + for (var i = 0; i < 2 * len; i++) { + arr[i] = 0; + } + for (var i = 0; i < self.bits_.length; i++) { + for (var j = 0; j < other.bits_.length; j++) { + var a1 = getBits(self, i) >>> 16; + var a0 = getBits(self, i) & 0xFFFF; + + var b1 = getBits(other, j) >>> 16; + var b0 = getBits(other, j) & 0xFFFF; + + arr[2 * i + 2 * j] += a0 * b0; + Integer.carry16_(arr, 2 * i + 2 * j); + arr[2 * i + 2 * j + 1] += a1 * b0; + Integer.carry16_(arr, 2 * i + 2 * j + 1); + arr[2 * i + 2 * j + 1] += a0 * b1; + Integer.carry16_(arr, 2 * i + 2 * j + 1); + arr[2 * i + 2 * j + 2] += a1 * b1; + Integer.carry16_(arr, 2 * i + 2 * j + 2); + } + } + + for (var i = 0; i < len; i++) { + arr[i] = (arr[2 * i + 1] << 16) | arr[2 * i]; + } + for (var i = len; i < 2 * len; i++) { + arr[i] = 0; + } + return new Integer(arr, 0); +}; + +Integer.carry16_ = function(bits, index) { + while ((bits[index] & 0xFFFF) != bits[index]) { + bits[index + 1] += bits[index] >>> 16; + bits[index] &= 0xFFFF; + } +}; + +var I_mod = function(self, other) { + return I_rem(I_add(other, I_rem(self, other)), other); +} + +var I_div = function(self, other) { + if(greaterThan(self, Integer.ZERO) != greaterThan(other, Integer.ZERO)) { + if(I_rem(self, other) != Integer.ZERO) { + return I_sub(I_quot(self, other), Integer.ONE); + } + } + return I_quot(self, other); +} + +var I_quotRem = function(self, other) { + return [1, I_quot(self, other), I_rem(self, other)]; +} + +var I_divMod = function(self, other) { + return [1, I_div(self, other), I_mod(self, other)]; +} + +var I_quot = function(self, other) { + if (isZero(other)) { + throw Error('division by zero'); + } else if (isZero(self)) { + return Integer.ZERO; + } + + if (isNegative(self)) { + if (isNegative(other)) { + return I_quot(I_negate(self), I_negate(other)); + } else { + return I_negate(I_quot(I_negate(self), other)); + } + } else if (isNegative(other)) { + return I_negate(I_quot(self, I_negate(other))); + } + + var res = Integer.ZERO; + var rem = self; + while (greaterThanOrEqual(rem, other)) { + var approx = Math.max(1, Math.floor(I_toNumber(rem) / I_toNumber(other))); + var log2 = Math.ceil(Math.log(approx) / Math.LN2); + var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48); + var approxRes = I_fromNumber(approx); + var approxRem = I_mul(approxRes, other); + while (isNegative(approxRem) || greaterThan(approxRem, rem)) { + approx -= delta; + approxRes = I_fromNumber(approx); + approxRem = I_mul(approxRes, other); + } + + if (isZero(approxRes)) { + approxRes = Integer.ONE; + } + + res = I_add(res, approxRes); + rem = I_sub(rem, approxRem); + } + return res; +}; + +var I_rem = function(self, other) { + return I_sub(self, I_mul(I_quot(self, other), other)); +}; + +var not = function(self) { + var len = self.bits_.length; + var arr = []; + for (var i = 0; i < len; i++) { + arr[i] = ~self.bits_[i]; + } + return new Integer(arr, ~self.sign_); +}; + +var I_and = function(self, other) { + var len = Math.max(self.bits_.length, other.bits_.length); + var arr = []; + for (var i = 0; i < len; i++) { + arr[i] = getBits(self, i) & getBits(other, i); + } + return new Integer(arr, self.sign_ & other.sign_); +}; + +var I_or = function(self, other) { + var len = Math.max(self.bits_.length, other.bits_.length); + var arr = []; + for (var i = 0; i < len; i++) { + arr[i] = getBits(self, i) | getBits(other, i); + } + return new Integer(arr, self.sign_ | other.sign_); +}; + +var I_xor = function(self, other) { + var len = Math.max(self.bits_.length, other.bits_.length); + var arr = []; + for (var i = 0; i < len; i++) { + arr[i] = getBits(self, i) ^ getBits(other, i); + } + return new Integer(arr, self.sign_ ^ other.sign_); +}; + +var I_shiftLeft = function(self, numBits) { + var arr_delta = numBits >> 5; + var bit_delta = numBits % 32; + var len = self.bits_.length + arr_delta + (bit_delta > 0 ? 1 : 0); + var arr = []; + for (var i = 0; i < len; i++) { + if (bit_delta > 0) { + arr[i] = (getBits(self, i - arr_delta) << bit_delta) | + (getBits(self, i - arr_delta - 1) >>> (32 - bit_delta)); + } else { + arr[i] = getBits(self, i - arr_delta); + } + } + return new Integer(arr, self.sign_); +}; + +var I_shiftRight = function(self, numBits) { + var arr_delta = numBits >> 5; + var bit_delta = numBits % 32; + var len = self.bits_.length - arr_delta; + var arr = []; + for (var i = 0; i < len; i++) { + if (bit_delta > 0) { + arr[i] = (getBits(self, i + arr_delta) >>> bit_delta) | + (getBits(self, i + arr_delta + 1) << (32 - bit_delta)); + } else { + arr[i] = getBits(self, i + arr_delta); + } + } + return new Integer(arr, self.sign_); +}; + +var I_signum = function(self) { + var cmp = I_compare(self, Integer.ZERO); + if(cmp > 0) { + return Integer.ONE + } + if(cmp < 0) { + return I_sub(Integer.ZERO, Integer.ONE); + } + return Integer.ZERO; +}; + +var I_abs = function(self) { + if(I_compare(self, Integer.ZERO) < 0) { + return I_sub(Integer.ZERO, self); + } + return self; +}; + +var I_decodeDouble = function(x) { + var dec = decodeDouble(x); + var mantissa = Integer.fromBits([dec[3], dec[2]]); + if(dec[1] < 0) { + mantissa = I_negate(mantissa); + } + return [1, dec[4], mantissa]; +} + +var I_toString = function(self) { + var radix = 10; + + if (isZero(self)) { + return '0'; + } else if (isNegative(self)) { + return '-' + I_toString(I_negate(self)); + } + + var radixToPower = I_fromNumber(Math.pow(radix, 6)); + + var rem = self; + var result = ''; + while (true) { + var remDiv = I_div(rem, radixToPower); + var intval = I_toInt(I_sub(rem, I_mul(remDiv, radixToPower))); + var digits = intval.toString(); + + rem = remDiv; + if (isZero(rem)) { + return digits + result; + } else { + while (digits.length < 6) { + digits = '0' + digits; + } + result = '' + digits + result; + } + } +}; + +var I_fromRat = function(a, b) { + return I_toNumber(a) / I_toNumber(b); +} diff --git a/lib/MVar.js b/lib/MVar.js new file mode 100644 --- /dev/null +++ b/lib/MVar.js @@ -0,0 +1,55 @@ +// MVar implementation. +// Since Haste isn't concurrent, takeMVar and putMVar don't block on empty +// and full MVars respectively, but terminate the program since they would +// otherwise be blocking forever. + +function newMVar() { + return ({empty: true}); +} + +function tryTakeMVar(mv) { + if(mv.empty) { + return [1, 0, undefined]; + } else { + mv.empty = true; + mv.x = null; + return [1, 1, mv.x]; + } +} + +function takeMVar(mv) { + if(mv.empty) { + // TODO: real BlockedOnDeadMVar exception, perhaps? + err("Attempted to take empty MVar!"); + } + mv.empty = true; + mv.x = null; + return mv.x; +} + +function putMVar(mv, val) { + if(!mv.empty) { + // TODO: real BlockedOnDeadMVar exception, perhaps? + err("Attempted to put full MVar!"); + } + mv.empty = false; + mv.x = val; +} + +function tryPutMVar(mv, val) { + if(!mv.empty) { + return 0; + } else { + mv.empty = false; + mv.x = val; + return 1; + } +} + +function sameMVar(a, b) { + return (a == b); +} + +function isEmptyMVar(mv) { + return mv.empty ? 1 : 0; +} diff --git a/lib/StableName.js b/lib/StableName.js new file mode 100644 --- /dev/null +++ b/lib/StableName.js @@ -0,0 +1,21 @@ +// Implementation of stable names. +// Unlike native GHC, the garbage collector isn't going to move data around +// in a way that we can detect, so each object could serve as its own stable +// name if it weren't for the fact we can't turn a JS reference into an +// integer. +// So instead, each object has a unique integer attached to it, which serves +// as its stable name. + +var __next_stable_name = 1; + +function makeStableName(x) { + if(!x.stableName) { + x.stableName = __next_stable_name; + __next_stable_name += 1; + } + return x.stableName; +} + +function eqStableName(x, y) { + return (x == y) ? 1 : 0; +} diff --git a/lib/array.js b/lib/array.js new file mode 100644 --- /dev/null +++ b/lib/array.js @@ -0,0 +1,36 @@ +// Functions for dealing with arrays. + +function newArr(n, x) { + var arr = []; + for(; n >= 0; --n) { + arr.push(x); + } + return arr; +} + +// Create all views at once; perhaps it's wasteful, but it's better than having +// to check for the right view at each read or write. +function newByteArr(n) { + // Pad the thing to multiples of 8. + var padding = 8 - n % 8; + if(padding < 8) { + n += padding; + } + var arr = {}; + var buffer = new ArrayBuffer(n); + var views = {}; + views['i8'] = new Int8Array(buffer); + views['i16'] = new Int16Array(buffer); + views['i32'] = new Int32Array(buffer); + views['w8'] = new Uint8Array(buffer); + views['w16'] = new Uint16Array(buffer); + views['w32'] = new Uint32Array(buffer); + views['f32'] = new Float32Array(buffer); + views['f64'] = new Float64Array(buffer); + arr['b'] = buffer; + arr['v'] = views; + // ByteArray and Addr are the same thing, so keep an offset if we get + // casted. + arr['off'] = 0; + return arr; +} diff --git a/lib/md5.js b/lib/md5.js new file mode 100644 --- /dev/null +++ b/lib/md5.js @@ -0,0 +1,157 @@ +// Joseph Myers' MD5 implementation; used under the BSD license. + +function md5cycle(x, k) { +var a = x[0], b = x[1], c = x[2], d = x[3]; + +a = ff(a, b, c, d, k[0], 7, -680876936); +d = ff(d, a, b, c, k[1], 12, -389564586); +c = ff(c, d, a, b, k[2], 17, 606105819); +b = ff(b, c, d, a, k[3], 22, -1044525330); +a = ff(a, b, c, d, k[4], 7, -176418897); +d = ff(d, a, b, c, k[5], 12, 1200080426); +c = ff(c, d, a, b, k[6], 17, -1473231341); +b = ff(b, c, d, a, k[7], 22, -45705983); +a = ff(a, b, c, d, k[8], 7, 1770035416); +d = ff(d, a, b, c, k[9], 12, -1958414417); +c = ff(c, d, a, b, k[10], 17, -42063); +b = ff(b, c, d, a, k[11], 22, -1990404162); +a = ff(a, b, c, d, k[12], 7, 1804603682); +d = ff(d, a, b, c, k[13], 12, -40341101); +c = ff(c, d, a, b, k[14], 17, -1502002290); +b = ff(b, c, d, a, k[15], 22, 1236535329); + +a = gg(a, b, c, d, k[1], 5, -165796510); +d = gg(d, a, b, c, k[6], 9, -1069501632); +c = gg(c, d, a, b, k[11], 14, 643717713); +b = gg(b, c, d, a, k[0], 20, -373897302); +a = gg(a, b, c, d, k[5], 5, -701558691); +d = gg(d, a, b, c, k[10], 9, 38016083); +c = gg(c, d, a, b, k[15], 14, -660478335); +b = gg(b, c, d, a, k[4], 20, -405537848); +a = gg(a, b, c, d, k[9], 5, 568446438); +d = gg(d, a, b, c, k[14], 9, -1019803690); +c = gg(c, d, a, b, k[3], 14, -187363961); +b = gg(b, c, d, a, k[8], 20, 1163531501); +a = gg(a, b, c, d, k[13], 5, -1444681467); +d = gg(d, a, b, c, k[2], 9, -51403784); +c = gg(c, d, a, b, k[7], 14, 1735328473); +b = gg(b, c, d, a, k[12], 20, -1926607734); + +a = hh(a, b, c, d, k[5], 4, -378558); +d = hh(d, a, b, c, k[8], 11, -2022574463); +c = hh(c, d, a, b, k[11], 16, 1839030562); +b = hh(b, c, d, a, k[14], 23, -35309556); +a = hh(a, b, c, d, k[1], 4, -1530992060); +d = hh(d, a, b, c, k[4], 11, 1272893353); +c = hh(c, d, a, b, k[7], 16, -155497632); +b = hh(b, c, d, a, k[10], 23, -1094730640); +a = hh(a, b, c, d, k[13], 4, 681279174); +d = hh(d, a, b, c, k[0], 11, -358537222); +c = hh(c, d, a, b, k[3], 16, -722521979); +b = hh(b, c, d, a, k[6], 23, 76029189); +a = hh(a, b, c, d, k[9], 4, -640364487); +d = hh(d, a, b, c, k[12], 11, -421815835); +c = hh(c, d, a, b, k[15], 16, 530742520); +b = hh(b, c, d, a, k[2], 23, -995338651); + +a = ii(a, b, c, d, k[0], 6, -198630844); +d = ii(d, a, b, c, k[7], 10, 1126891415); +c = ii(c, d, a, b, k[14], 15, -1416354905); +b = ii(b, c, d, a, k[5], 21, -57434055); +a = ii(a, b, c, d, k[12], 6, 1700485571); +d = ii(d, a, b, c, k[3], 10, -1894986606); +c = ii(c, d, a, b, k[10], 15, -1051523); +b = ii(b, c, d, a, k[1], 21, -2054922799); +a = ii(a, b, c, d, k[8], 6, 1873313359); +d = ii(d, a, b, c, k[15], 10, -30611744); +c = ii(c, d, a, b, k[6], 15, -1560198380); +b = ii(b, c, d, a, k[13], 21, 1309151649); +a = ii(a, b, c, d, k[4], 6, -145523070); +d = ii(d, a, b, c, k[11], 10, -1120210379); +c = ii(c, d, a, b, k[2], 15, 718787259); +b = ii(b, c, d, a, k[9], 21, -343485551); + +x[0] = add32(a, x[0]); +x[1] = add32(b, x[1]); +x[2] = add32(c, x[2]); +x[3] = add32(d, x[3]); + +} + +function cmn(q, a, b, x, s, t) { +a = add32(add32(a, q), add32(x, t)); +return add32((a << s) | (a >>> (32 - s)), b); +} + +function ff(a, b, c, d, x, s, t) { +return cmn((b & c) | ((~b) & d), a, b, x, s, t); +} + +function gg(a, b, c, d, x, s, t) { +return cmn((b & d) | (c & (~d)), a, b, x, s, t); +} + +function hh(a, b, c, d, x, s, t) { +return cmn(b ^ c ^ d, a, b, x, s, t); +} + +function ii(a, b, c, d, x, s, t) { +return cmn(c ^ (b | (~d)), a, b, x, s, t); +} + +function md51(s) { +txt = ''; +var n = s.length, +state = [1732584193, -271733879, -1732584194, 271733878], i; +for (i=64; i<=s.length; i+=64) { +md5cycle(state, md5blk(s.substring(i-64, i))); +} +s = s.substring(i-64); +var tail = [0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0]; +for (i=0; i>2] |= s.charCodeAt(i) << ((i%4) << 3); +tail[i>>2] |= 0x80 << ((i%4) << 3); +if (i > 55) { +md5cycle(state, tail); +for (i=0; i<16; i++) tail[i] = 0; +} +tail[14] = n*8; +md5cycle(state, tail); +return state; +} + +function md5blk(s) { +var md5blks = [], i; +for (i=0; i<64; i+=4) { +md5blks[i>>2] = s.charCodeAt(i) ++ (s.charCodeAt(i+1) << 8) ++ (s.charCodeAt(i+2) << 16) ++ (s.charCodeAt(i+3) << 24); +} +return md5blks; +} + +var hex_chr = '0123456789abcdef'.split(''); + +function rhex(n) +{ +var s='', j=0; +for(; j<4; j++) +s += hex_chr[(n >> (j * 8 + 4)) & 0x0F] ++ hex_chr[(n >> (j * 8)) & 0x0F]; +return s; +} + +function hex(x) { +for (var i=0; i b['off']; + } else { + return (a != 0); + } +} diff --git a/lib/rts.js b/lib/rts.js new file mode 100644 --- /dev/null +++ b/lib/rts.js @@ -0,0 +1,284 @@ +/* Thunk + Creates a thunk representing the given closure. + Since we want automatic memoization of as many expressions as possible, we + use a JS object as a sort of tagged pointer, where the member x denotes the + object actually pointed to. If a "pointer" points to a thunk, it has a + member 't' which is set to true; if it points to a value, be it a function, + a value of an algebraic type of a primitive value, it has no member 't'. +*/ + +function T(f) { + return new Thunk(f); +} + +function Thunk(f) { + this.f = f; +} + +/* Apply + Applies the function f to the arguments args. If the application is under- + saturated, a closure is returned, awaiting further arguments. If it is over- + saturated, the function is fully applied, and the result (assumed to be a + function) is then applied to the remaining arguments. +*/ +function A(f, args) { + f = f instanceof Thunk ? 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. + if(!f.apply) { + return f; + } + + var arity = f.arity ? f.arity : f.length; + if(args.length === arity) { + return f.apply(null, args); + } + if(args.length > arity) { + var first = args.splice(0, arity); + return A(f.apply(null, first), args); + } else { + var g = function() { + var as = args.concat(Array.prototype.slice.call(arguments)); + return A(f, as); + }; + g.arity = arity - args.length; + return g; + } +} + +/* Eval + Evaluate the given thunk t into head normal form. + If the "thunk" we get isn't actually a thunk, just return it. +*/ +function E(t) { + if(t instanceof Thunk) { + if(t.f) { + t.x = t.f(); + t.f = 0; + } + return t.x; + } + return t; +} + +/* Throw an error. + We need to be able to use throw as an exception so we wrap it in a function. +*/ +function die(err) { + throw err; +} + +function quot(a, b) { + return (a-a%b)/b; +} + +function quotRemI(a, b) { + return [1, (a-a%b)/b, a%b]; +} + +// 32 bit integer multiplication, with correct overflow behavior +// note that |0 or >>>0 needs to be applied to the result, for int and word +// respectively. +function imul(a, b) { + // ignore high a * high a as the result will always be truncated + var lows = (a & 0xffff) * (b & 0xffff); // low a * low b + var aB = (a & 0xffff) * (b & 0xffff0000); // low a * high b + var bA = (a & 0xffff0000) * (b & 0xffff); // low b * high a + return lows + aB + bA; // sum will not exceed 52 bits, so it's safe +} + +function addC(a, b) { + var x = a+b; + return [1, x & 0xffffffff, x > 0x7fffffff]; +} + +function subC(a, b) { + var x = a-b; + return [1, x & 0xffffffff, x < -2147483648]; +} + +function sinh (arg) { + return (Math.exp(arg) - Math.exp(-arg)) / 2; +} + +function tanh (arg) { + return (Math.exp(arg) - Math.exp(-arg)) / (Math.exp(arg) + Math.exp(-arg)); +} + +function cosh (arg) { + return (Math.exp(arg) + Math.exp(-arg)) / 2; +} + +// Scratch space for byte arrays. +var rts_scratchBuf = new ArrayBuffer(8); +var rts_scratchW32 = new Uint32Array(rts_scratchBuf); +var rts_scratchFloat = new Float32Array(rts_scratchBuf); +var rts_scratchDouble = new Float64Array(rts_scratchBuf); + +function decodeFloat(x) { + rts_scratchFloat[0] = x; + var sign = x < 0 ? -1 : 1; + var exp = ((rts_scratchW32[0] >> 23) & 0xff) - 150; + var man = rts_scratchW32[0] & 0x7fffff; + if(exp === 0) { + ++exp; + } else { + man |= (1 << 23); + } + return [1, sign*man, exp]; +} + +function decodeDouble(x) { + rts_scratchDouble[0] = x; + var sign = x < 0 ? -1 : 1; + var manHigh = rts_scratchW32[1] & 0xfffff; + var manLow = rts_scratchW32[0]; + var exp = ((rts_scratchW32[1] >> 20) & 0x7ff) - 1075; + if(exp === 0) { + ++exp; + } else { + manHigh |= (1 << 20); + } + return [1, sign, manHigh, manLow, exp]; +} + +function err(str) { + die(toJSStr(str)[1]); +} + +/* unpackCString# + NOTE: update constructor tags if the code generator starts munging them. +*/ +function unCStr(str) {return unAppCStr(str, [1]);} + +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]); + } + return acc; +} + +function unAppCStr(str, chrs) { + var i = arguments[2] ? arguments[2] : 0; + if(i >= str.length) { + return E(chrs); + } else { + return [2,[1,str.charCodeAt(i)],T(function() { + return unAppCStr(str,chrs,i+1); + })]; + } +} + +function charCodeAt(str, i) {return str.charCodeAt(i);} + +function fromJSStr(str) { + return unCStr(E(str)[1]); +} + +function toJSStr(hsstr) { + var s = ''; + for(var str = E(hsstr); str[0] == 2; str = E(str[2])) { + s += String.fromCharCode(E(str[1])[1]); + } + return [1,s]; +} + +// newMutVar +function nMV(val) { + return ({x: val}); +} + +// readMutVar +function rMV(mv) { + return mv.x; +} + +// writeMutVar +function wMV(mv, val) { + mv.x = val; +} + +function localeEncoding() { + var le = newByteArr(5); + le['b']['i8'] = 'U'.charCodeAt(0); + le['b']['i8'] = 'T'.charCodeAt(0); + le['b']['i8'] = 'F'.charCodeAt(0); + le['b']['i8'] = '-'.charCodeAt(0); + le['b']['i8'] = '8'.charCodeAt(0); + return le; +} + +var isFloatNaN = isDoubleNaN = isNaN; + +function isDoubleInfinite(d) { + return (d === Infinity); +} +var isFloatInfinite = isDoubleInfinite; + +function isDoubleNegativeZero(x) { + return (x===0 && (1/x)===-Infinity); +} +var isFloatNegativeZero = isDoubleNegativeZero; + +function strEq(a, b) { + return a == b; +} + +function strOrd(a, b) { + var ord; + if(a < b) { + ord = [1]; + } else if(a == b) { + ord = [2]; + } else { + ord = [3]; + } + return ord; +} + +function jsCatch(act, handler) { + try { + return A(act,[0]); + } catch(e) { + return A(handler,[e, 0]); + } +} + +function hs_eqWord64(a, b) { + return (a[0] == b[0] && a[1] == b[1]); +} + +// Word64# representation: (Word, Word) +function hs_wordToWord64(low) { + return [0, low]; +} + +function hs_mkWord64(high, low) { + return [high, low]; +} + +var coercionToken = undefined; + +/* Haste represents constructors internally using 1 for the first constructor, + 2 for the second, etc. + However, dataToTag should use 0, 1, 2, etc. Also, booleans might be unboxed. + */ +function dataToTag(x) { + if(x instanceof Array) { + return x[0]-1; + } else { + return x-1; + } +} + +function __word_encodeDouble(d, e) { + return d * Math.pow(2,e); +} + +var __word_encodeFloat = __word_encodeDouble; +var jsRound = Math.round; // Stupid GHC doesn't like periods in FFI IDs... +if(typeof _ == 'undefined') { + var _ = undefined; +} diff --git a/lib/stdlib.js b/lib/stdlib.js new file mode 100644 --- /dev/null +++ b/lib/stdlib.js @@ -0,0 +1,288 @@ +function jsAlert(val) { + if(typeof alert != 'undefined') { + alert(val); + } else { + print(val); + } +} + +function jsLog(val) { + console.log(val); +} + +function jsPrompt(str) { + var val; + if(typeof prompt != 'undefined') { + val = prompt(str); + } else { + print(str); + val = readline(); + } + return val == undefined ? '' : val.toString(); +} + +function jsEval(str) { + var x = eval(str); + return x == undefined ? '' : x.toString(); +} + +function isNull(obj) { + return obj === null; +} + +function jsRead(str) { + return Number(str); +} + +function jsShowI(val) {return val.toString();} +function jsShow(val) { + var ret = val.toString(); + return val == Math.round(val) ? ret + '.0' : ret; +} + +function jsSetCB(elem, evt, cb) { + // Count return press in single line text box as a change event. + if(evt == 'change' && elem.type.toLowerCase() == 'text') { + setCB(elem, 'keyup', function(k) { + if(k == '\n'.charCodeAt(0)) { + A(cb,[[1,k.keyCode],0]); + } + }); + } + + var fun; + switch(evt) { + case 'click': + case 'dblclick': + case 'mouseup': + case 'mousedown': + fun = function(x) {A(cb,[[1,x.button],0]);}; + break; + case 'keypress': + case 'keyup': + case 'keydown': + fun = function(x) {A(cb,[[1,x.keyCode],0]);}; + break; + default: + fun = function() {A(cb,[0]);}; + break; + } + return setCB(elem, evt, fun); +} + +function setCB(elem, evt, cb) { + if(elem.addEventListener) { + elem.addEventListener(evt, cb, false); + return true; + } else if(elem.attachEvent) { + elem.attachEvent('on'+evt, cb); + return true; + } + return false; +} + +function jsSetTimeout(msecs, cb) { + window.setTimeout(function() {A(cb,[0]);}, msecs); +} + +// Degenerate versions of u_iswspace, u_iswalnum and u_iswalpha. +function u_iswspace(c) { + return c==9 || c==10 || c==13 || c==32; +} + +function u_iswalnum(c) { + return (c >= 48 && c <= 57) || u_iswalpha(c); +} + +// [a-zA-ZåäöÅÄÖ] +function u_iswalpha(c) { + return (c >= 65 && c <= 90) || (c >= 97 && c <= 122) || + c == 229 || c == 228 || c == 246 || + c == 197 || c == 196 || c == 214; +} + +function jsGet(elem, prop) { + return elem[prop].toString(); +} + +function jsSet(elem, prop, val) { + elem[prop] = val; +} + +function jsGetStyle(elem, prop) { + return elem.style[prop].toString(); +} + +function jsSetStyle(elem, prop, val) { + elem.style[prop] = val; +} + +function jsKillChild(child, parent) { + parent.removeChild(child); +} + +function jsClearChildren(elem) { + while(elem.hasChildNodes()){ + elem.removeChild(elem.lastChild); + } +} + +function jsFind(elem) { + var e = document.getElementById(elem) + if(e) { + return [2,[1,e]]; + } + return [1]; +} + +function jsCreateElem(tag) { + return document.createElement(tag); +} + +function jsGetChildBefore(elem) { + elem = elem.previousSibling; + while(elem) { + if(typeof elem.tagName != 'undefined') { + return [2,[1,elem]]; + } + elem = elem.previousSibling; + } + return [1]; +} + +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]; +} + +function jsGetChildren(elem) { + var children = [1]; + 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]; + } + } + return children; +} + +function jsSetChildren(elem, children) { + children = E(children); + jsClearChildren(elem, 0); + while(children[0] === 2) { + elem.appendChild(E(E(children[1])[1])); + children = E(children[2]); + } +} + +function jsAppendChild(child, container) { + container.appendChild(child); +} + +function jsAddChildBefore(child, container, after) { + container.insertBefore(child, after); +} + +var jsRand = Math.random; + +// Concatenate a Haskell list of JS strings +function jsCat(strs, sep) { + var arr = []; + strs = E(strs); + while(strs[0] != 1) { + strs = E(strs); + arr.push(E(strs[1])[1]); + strs = E(strs[2]); + } + return arr.join(sep); +} + +// Escape all double quotes in a string +function jsUnquote(str) { + return str.replace(/"/, '\\"'); +} + +// Parse a JSON message into a Haste.JSON.JSON value. +// As this pokes around inside Haskell values, it'll need to be updated if: +// * Haste.JSON.JSON changes; +// * E() starts to choke on non-thunks; +// * data constructor code generation changes; or +// * Just and Nothing change tags. +function jsParseJSON(str) { + try { + var js = JSON.parse(str); + var hs = toHS(js); + } catch(_) { + return [1]; + } + return [2,hs]; +} + +function toHS(obj) { + switch(typeof obj) { + case 'number': + return [1, [1, jsRead(obj)]]; + case 'string': + return [2, [1, obj]]; + break; + case 'boolean': + return [3, obj]; // Booleans are special wrt constructor tags! + break; + case 'object': + if(obj instanceof Array) { + return [4, 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 + // considering that lots of people rely on keys being "in order" as + // defined by "the same way someone put them in at the other end," + // it's probably a good idea to put some cycles into meeting their + // misguided expectations. + var ks = []; + for(var k in obj) { + ks.unshift(k); + } + var xs = [1]; + for(var i in ks) { + xs = [2, [1, [1,ks[i]], toHS(obj[ks[i]])], xs]; + } + return [5, xs]; + } + } +} + +function arr2lst(arr, elem) { + if(elem >= arr.length) { + return [1]; + } + return [2, toHS(arr[elem]), T(function() {return arr2lst(arr,elem+1);})] +} + +function ajaxReq(method, url, async, postdata, cb) { + var xhr = new XMLHttpRequest(); + xhr.open(method, url, async); + xhr.setRequestHeader('Cache-control', 'no-cache'); + xhr.onreadystatechange = function() { + if(xhr.readyState == 4) { + if(xhr.status == 200) { + A(cb,[[2,[1,xhr.responseText]],0]); + } else { + A(cb,[[1],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/src/ArgSpecs.hs b/src/ArgSpecs.hs new file mode 100644 --- /dev/null +++ b/src/ArgSpecs.hs @@ -0,0 +1,121 @@ +-- | All of hastec's command line arguments. +module ArgSpecs (argSpecs) where +import Args +import Haste.Config +import Haste.Environment +import Data.JSTarget.PP (debugPPOpts) + +argSpecs :: [ArgSpec Config] +argSpecs = [ + ArgSpec { optName = "debug", + updateCfg = \cfg _ -> cfg {ppOpts = debugPPOpts}, + info = "Output indented, fairly readable code, with all " ++ + "external names included in comments."}, + ArgSpec { optName = "dont-link", + updateCfg = \cfg _ -> cfg {performLink = False}, + info = "Don't perform linking."}, + ArgSpec { optName = "libinstall", + updateCfg = \cfg _ -> cfg {targetLibPath = jsmodDir, + performLink = False}, + 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."}, + ArgSpec { optName = "opt-all-unsafe", + updateCfg = optAllUnsafe, + info = "Enable all safe and unsafe optimizations.\n" + ++ "Equivalent to --opt-all --opt-unsafe-ints."}, + ArgSpec { optName = "opt-google-closure", + updateCfg = updateClosureCfg, + info = "Run the Google Closure compiler on the output. " + ++ "Use --opt-google-closure=foo.jar to hint that foo.jar " + ++ "is the Closure compiler."}, + ArgSpec { optName = "opt-sloppy-tce", + updateCfg = useSloppyTCE, + info = "Allow the possibility that some tail recursion may not " + ++ "be optimized, to get\nslightly smaller code."}, + ArgSpec { optName = "opt-unsafe-ints", + updateCfg = unsafeMath, + info = "Enable all unsafe Int math optimizations. Equivalent to " + ++ "--opt-unsafe-mult --opt-vague-ints"}, + ArgSpec { optName = "opt-unsafe-mult", + updateCfg = unsafeMul, + info = "Use Javascript's built-in multiplication operator for " + ++ "fixed precision integer multiplication. This speeds " + ++ "up Int multiplication by a factor of at least four, " + ++ "but may give incorrect results when the product " + ++ "falls outside the interval [-2^52, 2^52]."}, + ArgSpec { optName = "opt-vague-ints", + updateCfg = vagueInts, + info = "Int math has 53 bits of precision, but gives incorrect " + ++ "results rather than properly wrapping around when " + ++ "those 53 bits are exceeded. Bitwise operations still " + ++ "only work on the lowest 32 bits. This option should " + ++ "give a substantial performance boost for Int math " + ++ "heavy code."}, + ArgSpec { optName = "opt-whole-program", + updateCfg = enableWholeProgramOpts, + info = "Perform optimizations over the whole program at link " + ++ "time.\nMay significantly increase compilation time."}, + ArgSpec { optName = "out=", + updateCfg = \cfg outfile -> cfg {outFile = const $ head outfile}, + info = "Write the JS blob to ."}, + ArgSpec { optName = "start=asap", + updateCfg = \cfg _ -> cfg {appStart = startASAP}, + info = "Start program immediately instead of on document load."}, + ArgSpec { optName = "verbose", + updateCfg = \cfg _ -> cfg {verbose = True}, + info = "Display even the most obnoxious warnings."}, + ArgSpec { optName = "with-js=", + updateCfg = \cfg args -> cfg {jsExternals = args}, + info = "Comma-separated list of .js files to include in the " + ++ "final JS bundle."} + ] + +-- | Compose two config update functions. Be careful about using any args with +-- them though! +(|||) :: (Config -> [String] -> Config) + -> (Config -> [String] -> Config) + -> (Config -> [String] -> Config) +a ||| b = \cfg args -> b (a cfg args) args + +-- | Don't wrap Ints. +vagueInts :: Config -> [String] -> Config +vagueInts cfg _ = cfg {wrapIntMath = id} + +-- | Use fast but unsafe multiplication. +unsafeMul :: Config -> [String] -> Config +unsafeMul cfg _ = cfg {multiplyIntOp = fastMultiply} + +-- | Enable all unsafe math ops. Remember to update the info text when changing +-- this! +unsafeMath :: Config -> [String] -> Config +unsafeMath = vagueInts ||| unsafeMul + +-- | Enable all optimizations, both safe and unsafe. +optAllUnsafe :: Config -> [String] -> Config +optAllUnsafe = optAllSafe ||| unsafeMath + +-- | Enable all safe optimizations. +optAllSafe :: Config -> [String] -> Config +optAllSafe = updateClosureCfg ||| enableWholeProgramOpts + +-- | Set the path to the Closure compiler.jar to use. +updateClosureCfg :: Config -> [String] -> Config +updateClosureCfg cfg ['=':arg] = + cfg {useGoogleClosure = Just arg} +updateClosureCfg cfg _ = + cfg {useGoogleClosure = Just closureCompiler} + +-- | Enable optimizations over the entire program. +enableWholeProgramOpts :: Config -> [String] -> Config +enableWholeProgramOpts cfg _ = cfg {wholeProgramOpts = True} + +-- | Enable sloppy TCE; see Config for more info. +useSloppyTCE :: Config -> [String] -> Config +useSloppyTCE cfg _ = cfg {sloppyTCE = True} diff --git a/src/Args.hs b/src/Args.hs new file mode 100644 --- /dev/null +++ b/src/Args.hs @@ -0,0 +1,53 @@ +module Args (ArgSpec (..), handleArgs) where +import Data.List (partition, stripPrefix) + +data ArgSpec a = ArgSpec { + optName :: String, + updateCfg :: a -> [String] -> a, + info :: String + } + +-- | Updates a config based on the given list of ArgSpecs and command line +-- arguments. If --help is encountered within the arguments, we stop +-- everything and just return a help message. +handleArgs :: a -> [ArgSpec a] -> [String] -> Either String (a, [String]) +handleArgs cfg specs args = + if elem "--help" cfgargs + then Left (printHelp specs) + else Right (foldl (matchSpec specs) cfg (map (drop 2) cfgargs), rest) + where + (cfgargs, rest) = partition ((== "--") . take 2) args + +matchSpec :: [ArgSpec a] -> a -> String -> a +matchSpec specs cfg arg = + foldl updCfg cfg matchingSpecs + where + updCfg cfg' (spec, args) = + updateCfg spec cfg' (commaBreak args) + specArgs = + map (\spec -> stripPrefix (optName spec) arg) specs + matchingSpecs = + map (\(s, Just a) -> (s, a)) $ filter isMatching (zip specs specArgs) + isMatching (_, Nothing) = False + isMatching _ = True + +-- | Like 'words', except it breaks on commas instead of spaces. +commaBreak :: String -> [String] +commaBreak [] = [] +commaBreak s = + case span (/= ',') s of + (w, ws) -> w : commaBreak (drop 1 ws) + +printHelp :: [ArgSpec a] -> String +printHelp = unlines . map helpString + +helpString :: ArgSpec a -> String +helpString spec = + "--" ++ hdr ++ "\n " + ++ info spec + ++ "\n" + where + hdr = + case last $ optName spec of + '=' -> optName spec ++ "" + _ -> optName spec diff --git a/src/Control/Shell.hs b/src/Control/Shell.hs new file mode 100644 --- /dev/null +++ b/src/Control/Shell.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +-- | Simple interface for shell scripting-like tasks. +module Control.Shell ( + Shell, shell, + mayFail, + withEnv, getEnv, lookupEnv, + run, run_, run', runInteractive, + cd, cpDir, pwd, ls, mkdir, rmdir, inDirectory, isDirectory, + withHomeDirectory, inHomeDirectory, withAppDirectory, inAppDirectory, + isFile, rm, mv, cp, file, mtime, + withTempFile, withTempDirectory, inTempDirectory, + module System.FilePath, + ) where +import Control.Applicative +import Control.Monad (ap) +import Control.Monad.IO.Class +import Data.Time.Clock +import System.FilePath +import qualified System.Process as Proc +import qualified System.Directory as Dir +import qualified System.Exit as Exit +import qualified System.IO as IO +import qualified Control.Exception as Ex +import qualified System.IO.Temp as Temp +import qualified System.Environment as Env + +-- | Environment variables. +type Env = [(String, String)] + +-- | Monad for running shell commands. If a command fails, the entire +-- computation is aborted unless @mayFail@ is used. +newtype Shell a = Shell {unSh :: Env -> IO (Either String a)} + +instance Monad Shell where + fail err = Shell $ \_ -> return $ Left err + return x = Shell $ \_ -> return $ Right x + (Shell m) >>= f = Shell $ \env -> do + x <- m env + case x of + Right x' -> unSh (f x') env + Left err -> return $ Left err + +instance MonadIO Shell where + liftIO act = Shell $ \_ -> Ex.catch (fmap Right act) exHandler + +instance Applicative Shell where + pure = return + (<*>) = ap + +instance Functor Shell where + fmap f (Shell x) = Shell $ \env -> fmap (fmap f) (x env) + +-- | Enable the user to use 'file "foo" >>= fmap reverse >>= file "bar"' as +-- syntax for reading the file 'foo', reversing the contents and writing the +-- result to 'bar'. +-- Note that this uses lazy IO in the form of read/writeFile. +class File a where + file :: FilePath -> a + +instance File (String -> Shell ()) where + file f = liftIO . writeFile f + +instance File (Shell String) where + file f = liftIO $ readFile f + +-- | Run a Shell computation. The program's working directory will be restored +-- after executing the computation. +shell :: Shell a -> IO (Either String a) +shell act = do + dir <- Dir.getCurrentDirectory + env <- Env.getEnvironment + res <- unSh act env + Dir.setCurrentDirectory dir + return res + +-- | Run a computation with a new value for an environment variable. +-- Note that this will *not* affect external commands spawned using @liftIO@ +-- or which directory is considered the system temp directory. +withEnv :: String -> (String -> String) -> Shell a -> Shell a +withEnv key f (Shell act) = Shell $ \env -> do + act $ insert env + where + insert (x@(k,v):xs) | k == key = (key, f v) : xs + | otherwise = x : insert xs + insert _ = [(key, f "")] + +-- | Get the value of an environment variable. Returns Nothing if the variable +-- doesn't exist. +lookupEnv :: String -> Shell (Maybe String) +lookupEnv key = Shell $ return . Right . lookup key + +-- | Get the value of an environment variable. Returns the empty string if +-- the variable doesn't exist. +getEnv :: String -> Shell String +getEnv key = maybe "" id `fmap` lookupEnv key + +-- | General exception handler; any exception causes failure. +exHandler :: Ex.SomeException -> IO (Either String a) +exHandler = return . Left . show + +-- | Execute an external command. No globbing, escaping or other external shell +-- magic is performed on either the command or arguments. The program's text +-- output will be returned, and not echoed to the screen. +-- The text output is read strictly, so this is not suitable for interactive +-- commands. +run :: String -> [String] -> String -> Shell String +run p args stdin = do + (Just inp, Just out, _) <- runP p args Proc.CreatePipe Proc.CreatePipe + liftIO $ do + IO.hPutStr inp stdin + IO.hClose inp + IO.hGetContents out + +-- | Like @run@, but echoes the command's text output to the screen instead of +-- returning it. Waits for the command to complete before returning. +run_ :: String -> [String] -> String -> Shell () +run_ p args stdin = do + (Just inp, _, pid) <- runP p args Proc.CreatePipe Proc.Inherit + exCode <- liftIO $ do + IO.hPutStr inp stdin + IO.hClose inp + Proc.waitForProcess pid + case exCode of + Exit.ExitFailure ec -> fail $ "Command '" ++ p ++ "' failed with error " + ++" code " ++ show ec + _ -> return () + +-- | Create a process. Helper for @run@ and friends. +runP :: String + -> [String] + -> Proc.StdStream + -> Proc.StdStream + -> Shell (Maybe IO.Handle, Maybe IO.Handle, Proc.ProcessHandle) +runP p args stdin stdout = Shell $ \env -> do + (inp, out, _, pid) <- Proc.createProcess (cproc env) + return $ Right (inp, out, pid) + where + cproc env = Proc.CreateProcess { + Proc.cmdspec = Proc.RawCommand p args, + Proc.cwd = Nothing, + Proc.env = Just env, + Proc.std_in = stdin, + Proc.std_out = stdout, + Proc.std_err = Proc.Inherit, + Proc.close_fds = False, + Proc.create_group = False + } + +-- | Run a command and wait for it to terminate before returning its output. +run' :: String -> [String] -> String -> Shell String +run' p args stdin = do + (Just inp, Just out, pid) <- runP p args Proc.Inherit Proc.Inherit + exCode <- liftIO $ do + IO.hPutStr inp stdin + IO.hClose inp + Proc.waitForProcess pid + case exCode of + Exit.ExitFailure ec -> fail $ "Command '" ++ p ++ "' failed with error " + ++" code " ++ show ec + _ -> liftIO $ IO.hGetContents out + +-- | Run an interactive process. +runInteractive :: String -> [String] -> Shell () +runInteractive p args = do + (_, _, pid) <- runP p args Proc.Inherit Proc.Inherit + exitCode <- liftIO $ Proc.waitForProcess pid + case exitCode of + Exit.ExitFailure ec -> fail (show ec) + _ -> return () + +-- | Change working directory. +cd :: FilePath -> Shell () +cd = liftIO . Dir.setCurrentDirectory + +-- | Get the current working directory. +pwd :: Shell FilePath +pwd = liftIO $ Dir.getCurrentDirectory + +-- | Remove a file. +rm :: FilePath -> Shell () +rm = liftIO . Dir.removeFile + +-- | Rename a file. +mv :: FilePath -> FilePath -> Shell () +mv from to = liftIO $ Dir.renameFile from to + +-- | Recursively copy a directory. If the target is a directory that already +-- exists, the source directory is copied into that directory using its +-- current name. +cpDir :: FilePath -> FilePath -> Shell () +cpDir from to = do + todir <- isDirectory to + if todir + then do + cpDir from (to takeBaseName from) + else do + cpfile <- isFile from + if cpfile + then do + cp from to + else do + liftIO $ Dir.createDirectoryIfMissing False to + ls from >>= mapM_ (\f -> cpDir (from f) (to f)) + +-- | Copy a file. Fails if the source is a directory. If the target is a +-- directory, the source file is copied into that directory using its current +-- name. +cp :: FilePath -> FilePath -> Shell () +cp from to = do + todir <- isDirectory to + if todir + then cp from (to takeFileName from) + else liftIO $ Dir.copyFile from to + +-- | List the contents of a directory, sans '.' and '..'. +ls :: FilePath -> Shell [FilePath] +ls dir = do + contents <- liftIO $ Dir.getDirectoryContents dir + return [f | f <- contents, f /= ".", f /= ".."] + +-- | Get the last time the given file was modified in UTC. +mtime :: FilePath -> Shell UTCTime +mtime = liftIO . Dir.getModificationTime + +-- | Create a directory. Optionally create any required missing directories as +-- well. +mkdir :: Bool -> FilePath -> Shell () +mkdir True = liftIO . Dir.createDirectoryIfMissing True +mkdir _ = liftIO . Dir.createDirectory + +-- | Recursively remove a directory. Follows symlinks, so be careful. +rmdir :: FilePath -> Shell () +rmdir = liftIO . Dir.removeDirectoryRecursive + +-- | Do something with the user's home directory. +withHomeDirectory :: (FilePath -> Shell a) -> Shell a +withHomeDirectory act = liftIO Dir.getHomeDirectory >>= act + +-- | Do something *in* the user's home directory. +inHomeDirectory :: Shell a -> Shell a +inHomeDirectory act = withHomeDirectory $ \dir -> inDirectory dir act + +-- | Do something with the given application's data directory. +withAppDirectory :: String -> (FilePath -> Shell a) -> Shell a +withAppDirectory app act = liftIO (Dir.getAppUserDataDirectory app) >>= act + +-- | Do something *in* the given application's data directory. +inAppDirectory :: FilePath -> Shell a -> Shell a +inAppDirectory app act = withAppDirectory app $ \dir -> inDirectory dir act + +-- | Execute a command in the given working directory, then restore the +-- previous working directory. +inDirectory :: FilePath -> Shell a -> Shell a +inDirectory dir act = do + curDir <- pwd + cd dir + x <- act + cd curDir + return x + +-- | Does the given path lead to a directory? +isDirectory :: FilePath -> Shell Bool +isDirectory = liftIO . Dir.doesDirectoryExist + +-- | Does the given path lead to a file? +isFile :: FilePath -> Shell Bool +isFile = liftIO . Dir.doesFileExist + +-- | Create a temp directory in the standard system temp directory, do +-- something with it, then remove it. +withTempDirectory :: String -> (FilePath -> Shell a) -> Shell a +withTempDirectory template act = Shell $ \env -> do + Temp.withSystemTempDirectory template (act' env) + where + act' env fp = Ex.catch (unSh (act fp) env) exHandler + +-- | Performs a command inside a temporary directory. The directory will be +-- cleaned up after the command finishes. +inTempDirectory :: Shell a -> Shell a +inTempDirectory = withTempDirectory "hsshell" . flip inDirectory + +-- | Create a temp file in the standard system temp directory, do something +-- with it, then remove it. +withTempFile :: String -> (FilePath -> IO.Handle -> Shell a) -> Shell a +withTempFile template act = Shell $ \env -> do + Temp.withSystemTempFile template (act' env) + where + act' env fp h = Ex.catch (unSh (act fp h) env) exHandler + +-- | Perform an action that may fail without aborting the entire computation. +mayFail :: Shell a -> Shell (Either String a) +mayFail (Shell act) = Shell $ \env -> do + x <- Ex.catch (act env) exHandler + return $ Right x diff --git a/src/Data/JSTarget.hs b/src/Data/JSTarget.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSTarget.hs @@ -0,0 +1,17 @@ +-- | Javascript subset as a target language for compilers. +module Data.JSTarget ( + module Constr, module Op, module Optimize, module Trav, + Fingerprint, PPOpts (..), pretty, runPP, prettyProg, def, + Arity, Comment, Shared, Name (..), Var (..), LHS, Call, + Lit, Exp, Stm, Alt, AST (..), Module (..), + foreignModule, moduleOf, pkgOf, blackHole, blackHoleVar + ) where +import Data.JSTarget.AST +import Data.JSTarget.Op as Op +import Data.JSTarget.Optimize as Optimize +import Data.JSTarget.Constructors as Constr +import Data.JSTarget.PP (pretty, runPP, prettyProg, PPOpts (..)) +import Data.JSTarget.Print as Print () +import Data.JSTarget.Binary () +import Data.JSTarget.Traversal as Trav +import Data.Default (def) diff --git a/src/Data/JSTarget/AST.hs b/src/Data/JSTarget/AST.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSTarget/AST.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances #-} +module Data.JSTarget.AST where +import qualified Data.Set as S +import qualified Data.Map as M +import System.IO.Unsafe +import System.Random (randomIO) +import Data.IORef +import Data.Word +import Control.Applicative +import Data.JSTarget.Op + +type Arity = Int +type Comment = String +type Reorderable = Bool + +-- | Shared statements. +newtype Shared a = Shared Lbl deriving (Eq, Show) + +data Name = Name String (Maybe (String, String)) deriving (Eq, Ord, Show) + +class HasModule a where + moduleOf :: a -> Maybe String + pkgOf :: a -> Maybe String + +instance HasModule Name where + moduleOf (Name _ mmod) = fmap snd mmod + pkgOf (Name _ mmod) = fmap fst mmod + +instance HasModule Var where + moduleOf (Foreign _) = Nothing + moduleOf (Internal n _) = moduleOf n + pkgOf (Foreign _) = Nothing + pkgOf (Internal n _) = pkgOf n + +-- | Representation of variables. +data Var where + Foreign :: String -> Var + Internal :: Name -> Comment -> Var + deriving (Show) + +instance Eq Var where + (Foreign f1) == (Foreign f2) = f1 == f2 + (Internal i1 _) == (Internal i2 _) = i1 == i2 + _ == _ = False + +instance Ord Var where + compare (Foreign f1) (Foreign f2) = compare f1 f2 + compare (Internal i1 _) (Internal i2 _) = compare i1 i2 + compare (Foreign _) (Internal _ _) = Prelude.LT + compare (Internal _ _) (Foreign _) = Prelude.GT + +-- | Left hand side of an assignment. Normally we only assign internal vars, +-- but for some primops we need to assign array elements as well. +-- LhsExp is never reorderable. +data LHS where + NewVar :: Reorderable -> Var -> LHS + LhsExp :: Exp -> LHS + deriving (Eq, Show) + +-- | Distinguish between normal, optimized and method calls. +data Call where + Normal :: Call + Fast :: Call + Method :: String -> Call + deriving (Eq, Show) + +-- | Literals; nothing fancy to see here. +data Lit where + LNum :: Double -> Lit + LStr :: String -> Lit + LBool :: Bool -> Lit + LInt :: Integer -> Lit + LNull :: Lit + deriving (Eq, Show) + +-- | Expressions. Completely predictable. +data Exp where + Var :: Var -> Exp + Lit :: Lit -> Exp + Not :: Exp -> Exp + BinOp :: BinOp -> Exp -> Exp -> Exp + Fun :: Maybe Name -> [Var] -> Stm -> Exp + Call :: Arity -> Call -> Exp -> [Exp] -> Exp + Index :: Exp -> Exp -> Exp + Arr :: [Exp] -> Exp + AssignEx :: Exp -> Exp -> Exp + IfEx :: Exp -> Exp -> Exp -> Exp + deriving (Eq, Show) + +-- | Statements. The only mildly interesting thing here are the Case and Jump +-- constructors, which allow explicit sharing of continuations. +data Stm where + Case :: Exp -> Stm -> [Alt] -> Shared Stm -> Stm + Forever :: Stm -> Stm + Assign :: LHS -> Exp -> Stm -> Stm + Return :: Exp -> Stm + Cont :: Stm + Jump :: Shared Stm -> Stm + NullRet :: Stm + deriving (Eq, Show) + +-- | Case alternatives - an expression to match and a branch. +type Alt = (Exp, Stm) + +-- | Module fingerprint, containing a hash of compiler options and other things +-- that may be used to determine whether the module needs recompiling or not. +type Fingerprint = String + +-- | Represents a module. A module has a name, a fingerprint, an owning +-- package, a dependency map of all its definitions, and a bunch of +-- definitions. +data Module = Module { + modFingerprint :: !Fingerprint, + modPackageId :: !String, + modName :: !String, + modDeps :: !(M.Map Name (S.Set Name)), + modDefs :: !(M.Map Name (AST Exp)) + } + +-- | Imaginary module for foreign code that may need one. +foreignModule :: Module +foreignModule = Module { + modFingerprint = "", + modPackageId = "", + modName = "", + modDeps = M.empty, + modDefs = M.empty + } + +-- | An LHS that's guaranteed to not ever be read, enabling the pretty +-- printer to ignore assignments to it. +blackHole :: LHS +blackHole = + LhsExp $ Var blackHoleVar + +-- | The variable of the blackHole LHS. +blackHoleVar :: Var +blackHoleVar = Internal (Name "" (Just ("$blackhole", "$blackhole"))) "" + +-- | An AST with local jumps. +data AST a = AST { + astCode :: a, + astJumps :: JumpTable + } deriving (Show, Eq) + +instance Functor AST where + fmap f (AST ast js) = AST (f ast) js + +instance Applicative AST where + pure = return + (AST f js) <*> (AST x js') = AST (f x) (M.union js' js) + +instance Monad AST where + return x = AST x M.empty + (AST ast js) >>= f = + case f ast of + AST ast' js' -> AST ast' (M.union js' js) + +-- | Returns the precedence of the top level operator of the given expression. +-- Everything that's not an operator has equal precedence, higher than any +-- binary operator. +expPrec :: Exp -> Int +expPrec (BinOp Sub (Lit (LNum 0)) _) = 500 -- 0-n is always printed as -n +expPrec (BinOp op _ _) = opPrec op +expPrec (Not _) = 500 +expPrec _ = 1000 + +type JumpTable = M.Map Lbl Stm + +data Lbl = Lbl !Word64 !Word64 deriving (Eq, Ord, Show) + +{-# NOINLINE nextLbl #-} +nextLbl :: IORef Word64 +nextLbl = unsafePerformIO $ newIORef 0 + +{-# NOINLINE lblNamespace #-} +-- | Namespace for labels, to avoid collisions when combining modules. +-- We really ought to make this f(package, module) or something, but a random +-- 64 bit unsigned int should suffice. +lblNamespace :: Word64 +lblNamespace = unsafePerformIO $ randomIO + +{-# NOINLINE lblFor #-} +-- | Produce a local reference to the given statement. +lblFor :: Stm -> AST Lbl +lblFor s = do + (r, s') <- freshRef + AST r (M.singleton r s') + where + freshRef = return $! unsafePerformIO $! do + r <- atomicModifyIORef' nextLbl (\lbl -> (lbl+1, Lbl lblNamespace lbl)) + -- We need to depend on s, or GHC will hoist us out of lblFor, possibly + -- causing circular dependencies between expressions. + return (r, s) diff --git a/src/Data/JSTarget/Binary.hs b/src/Data/JSTarget/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSTarget/Binary.hs @@ -0,0 +1,148 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Binary instances for JSTarget types. +module Data.JSTarget.Binary () where +import Prelude hiding (LT, GT) +import Data.Binary +import Data.Array +import Control.Applicative +import Data.JSTarget.AST +import Data.JSTarget.Op + +instance Binary a => Binary (AST a) where + put (AST x jumps) = put x >> put jumps + get = AST <$> get <*> get + +instance Binary Module where + put (Module fp pkgid name deps defs) = + put fp >> put pkgid >> put name >> put deps >> put defs + get = Module <$> get <*> get <*> get <*> get <*> get + +instance Binary Var where + put (Foreign str) = putWord8 0 >> put str + put (Internal name comment) = putWord8 1 >> put name >> put comment + + get = do + getWord8 >>= ([Foreign <$> get,Internal <$> get <*> get] !!) . fromIntegral + +instance Binary LHS where + put (NewVar r v) = putWord8 0 >> put r >> put v + put (LhsExp e) = putWord8 1 >> put e + + get = getWord8 >>= ([NewVar <$>get<*>get, LhsExp <$> get] !!) . fromIntegral + +instance Binary Call where + put Normal = putWord8 0 + put Fast = putWord8 1 + put (Method m) = putWord8 2 >> put m + + get = getWord8 >>= ([pure Normal,pure Fast,Method <$> get] !!) . fromIntegral + +instance Binary Lit where + put (LNum d) = putWord8 0 >> put d + put (LStr s) = putWord8 1 >> put s + put (LBool b) = putWord8 2 >> put b + put (LInt n) = putWord8 3 >> put n + put (LNull) = putWord8 4 + + get = do + t <- getWord8 + [LNum <$> get, LStr <$> get, LBool <$> get, LInt <$> get, pure LNull] !! + fromIntegral t + +instance Binary Exp where + put (Var v) = putWord8 0 >> put v + put (Lit l) = putWord8 1 >> put l + put (Not ex) = putWord8 2 >> put ex + put (BinOp op a b) = putWord8 3 >> put op >> put a >> put b + put (Fun nam as body) = putWord8 4 >> put nam >> put as >> put body + put (Call a c f xs) = putWord8 5 >> put a >> put c >> put f >> put xs + put (Index arr ix) = putWord8 6 >> put arr >> put ix + put (Arr exs) = putWord8 7 >> put exs + put (AssignEx l r) = putWord8 8 >> put l >> put r + put (IfEx c th el) = putWord8 9 >> put c >> put th >> put el + + get = do + tag <- getWord8 + case tag of + 0 -> Var <$> get + 1 -> Lit <$> get + 2 -> Not <$> get + 3 -> BinOp <$> get <*> get <*> get + 4 -> Fun <$> get <*> get <*> get + 5 -> Call <$> get <*> get <*> get <*> get + 6 -> Index <$> get <*> get + 7 -> Arr <$> get + 8 -> AssignEx <$> get <*> get + 9 -> IfEx <$> get <*> get <*> get + n -> error $ "Bad tag in get :: Get Exp: " ++ show n + +instance Binary Stm where + put (Case e def alts next) = + putWord8 0 >> put e >> put def >> put alts >> put next + put (Forever stm) = + putWord8 1 >> put stm + put (Assign lhs rhs next) = + putWord8 2 >> put lhs >> put rhs >> put next + put (Return ex) = + putWord8 3 >> put ex + put (Cont) = + putWord8 4 + put (Jump j) = + putWord8 5 >> put j + put (NullRet) = + putWord8 6 + + get = do + tag <- getWord8 + case tag of + 0 -> Case <$> get <*> get <*> get <*> get + 1 -> Forever <$> get + 2 -> Assign <$> get <*> get <*> get + 3 -> Return <$> get + 4 -> pure Cont + 5 -> Jump <$> get + 6 -> pure NullRet + n -> error $ "Bad tag in get :: Get Stm: " ++ show n + +instance Binary BinOp where + put Add = putWord8 0 + put Mul = putWord8 1 + put Sub = putWord8 2 + put Div = putWord8 3 + put Mod = putWord8 4 + put And = putWord8 5 + put Or = putWord8 6 + put Eq = putWord8 7 + put Neq = putWord8 8 + put LT = putWord8 9 + put GT = putWord8 10 + put LTE = putWord8 11 + put GTE = putWord8 12 + put Shl = putWord8 13 + put ShrL = putWord8 14 + put ShrA = putWord8 15 + put BitAnd = putWord8 16 + put BitOr = putWord8 17 + put BitXor = putWord8 18 + + get = (opTbl !) <$> getWord8 + +instance Binary Name where + put (Name name owner) = put name >> put owner + get = Name <$> get <*> get + +instance Binary a => Binary (Shared a) where + put (Shared lbl) = put lbl + get = Shared <$> get + +instance Binary Lbl where + put (Lbl namespace lbl) = put namespace >> put lbl + get = Lbl <$> get <*> get + +opTbl :: Array Word8 BinOp +opTbl = + listArray (0, arrLen-1) es + where + arrLen = fromIntegral $ length es + es = [Add, Mul, Sub, Div, Mod, And, Or, Eq, Neq, LT, GT, + LTE, GTE, Shl, ShrL, ShrA, BitAnd, BitOr, BitXor] diff --git a/src/Data/JSTarget/Constructors.hs b/src/Data/JSTarget/Constructors.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSTarget/Constructors.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE FlexibleInstances, OverlappingInstances, TupleSections #-} +-- | User interface for the JSTarget AST. +module Data.JSTarget.Constructors where +import Data.JSTarget.AST +import Data.JSTarget.Op +import Control.Applicative + +-- | Literal types. +class Literal a where + lit :: a -> AST Exp + +instance Literal Double where + lit = pure . Lit . LNum + +instance Literal Integer where + lit = pure . Lit . LInt + +instance Literal Bool where + lit = pure . Lit . LBool + +instance Literal [Char] where + lit = pure . Lit . LStr + +instance Literal a => Literal [a] where + lit xs = Arr <$> mapM lit xs + +instance Literal Exp where + lit = pure + +instance Literal Var where + lit = pure . Var + +litN :: Double -> AST Exp +litN = lit + +-- | Create a foreign variable. Foreign vars will not be subject to any name +-- mangling. +foreignVar :: String -> Var +foreignVar = Foreign + +-- | A regular, internal variable. Subject to name mangling. +internalVar :: Name -> String -> Var +internalVar = Internal + +-- | Create a name, qualified or not. +name :: String -> Maybe (String, String) -> Name +name = Name + +-- | A variable expression, for convenience. +var :: Name -> String -> AST Exp +var n comment = pure $ Var $ internalVar n comment + +-- | Turn a Var into an expression. +varExp :: Var -> AST Exp +varExp = pure . Var + +-- | Call to a native method on an object. Always saturated. +callMethod :: AST Exp -> String -> [AST Exp] -> AST Exp +callMethod obj meth args = + Call 0 (Method meth) <$> obj <*> sequence args + +-- | Foreign function call. Always saturated. +callForeign :: String -> [AST Exp] -> AST Exp +callForeign f = fmap (Call 0 Fast (Var $ foreignVar f)) . sequence + +-- | A normal function call. May be unsaturated. A saturated call is always +-- turned into a fast call. +call :: Arity -> AST Exp -> [AST Exp] -> AST Exp +call arity f xs = do + foldApp <$> (Call (arity - length xs) Normal <$> f <*> sequence xs) + +callSaturated :: AST Exp -> [AST Exp] -> AST Exp +callSaturated f xs = Call 0 Fast <$> f <*> sequence xs + +-- | "Fold" nested function applications into one, turning them into fast calls +-- if they turn out to be saturated. +foldApp :: Exp -> Exp +foldApp (Call arity Normal (Call _ Normal f args) args') = + foldApp (Call arity Normal f (args ++ args')) +foldApp (Call arity Normal f args) | arity == 0 = + Call arity Fast f args +foldApp ex = + ex + +-- | Create a thunk. +thunk :: AST Stm -> AST Exp +thunk stm = callForeign "T" [Fun Nothing [] <$> stm] + +-- | Evaluate an expression that may or may not be a thunk. +eval :: AST Exp -> AST Exp +eval = callForeign "E" . (:[]) + +-- | A binary operator. +binOp :: BinOp -> AST Exp -> AST Exp -> AST Exp +binOp op a b = BinOp op <$> a <*> b + +-- | Negate an expression. +not_ :: AST Exp -> AST Exp +not_ = fmap Not + +-- | Index into an array. +index :: AST Exp -> AST Exp -> AST Exp +index arr ix = Index <$> arr <*> ix + +-- | Create a function. +fun :: [Var] -> AST Stm -> AST Exp +fun args = fmap (Fun Nothing args) + +-- | Create an array of expressions. +array :: [AST Exp] -> AST Exp +array = fmap Arr . sequence + +-- | Case statement. +-- Takes a scrutinee expression, a default alternative, a list of more +-- specific alternatives, and a continuation statement. The continuation +-- will be explicitly shared among all the alternatives. +case_ :: AST Exp + -> (AST Stm -> AST Stm) + -> [(AST Exp, AST Stm -> AST Stm)] + -> AST Stm + -> AST Stm +case_ ex def alts cont = do + ex' <- ex + shared <- cont >>= lblFor + let jmp = pure $ Jump (Shared shared) + def' <- def jmp + alts' <- sequence [(,) <$> x <*> s jmp | (x, s) <- alts] + pure $ Case ex' def' alts' (Shared shared) + +-- | Return from a function. Only statement that doesn't take a continuation. +ret :: AST Exp -> AST Stm +ret = fmap Return + +-- | Create a new var with a new value. +newVar :: Reorderable -> Var -> AST Exp -> AST Stm -> AST Stm +newVar r lhs = liftA2 $ \rhs -> Assign (NewVar r lhs) rhs + +-- | Assignment without var. +assign :: AST Exp -> AST Exp -> AST Stm -> AST Stm +assign = liftA3 $ \lhs rhs -> Assign (LhsExp lhs) rhs + +-- | Assignment expression. +assignEx :: AST Exp -> AST Exp -> AST Exp +assignEx = liftA2 AssignEx + +-- | Terminate a statement without doing anything at all. +nullRet :: AST Stm +nullRet = pure NullRet diff --git a/src/Data/JSTarget/Op.hs b/src/Data/JSTarget/Op.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSTarget/Op.hs @@ -0,0 +1,68 @@ +module Data.JSTarget.Op where +import Prelude hiding (GT, LT) + +data BinOp + = Add + | Mul + | Sub + | Div + | Mod + | And + | Or + | Eq + | Neq + | LT + | GT + | LTE + | GTE + | Shl + | ShrL + | ShrA + | BitAnd + | BitOr + | BitXor + deriving (Eq) + +instance Show BinOp where + show Add = "+" + show Mul = "*" + show Sub = "-" + show Div = "/" + show Mod = "%" + show And = "&&" + show Or = "||" + show Eq = "==" + show Neq = "!=" + show LT = "<" + show GT = ">" + show LTE = "<=" + show GTE = ">=" + show Shl = "<<" + show ShrL = ">>>" + show ShrA = ">>" + show BitAnd = "&" + show BitOr = "|" + show BitXor = "^" + +-- | Returns the precedence of the given operator as an int. Higher number +-- means higher priority. +opPrec :: BinOp -> Int +opPrec Mul = 100 +opPrec Div = 100 +opPrec Mod = 100 +opPrec Add = 70 +opPrec Sub = 70 +opPrec Shl = 60 +opPrec ShrA = 60 +opPrec ShrL = 60 +opPrec LT = 50 +opPrec GT = 50 +opPrec LTE = 50 +opPrec GTE = 50 +opPrec Eq = 30 +opPrec Neq = 30 +opPrec BitAnd = 25 +opPrec BitXor = 24 +opPrec BitOr = 23 +opPrec And = 20 +opPrec Or = 10 diff --git a/src/Data/JSTarget/Optimize.hs b/src/Data/JSTarget/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSTarget/Optimize.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE PatternGuards, TupleSections, DoAndIfThenElse #-} +-- | Optimizations over the JSTarget AST. +module Data.JSTarget.Optimize ( + optimizeFun, tryTernary, topLevelInline + ) where +import Data.JSTarget.AST +import Data.JSTarget.Op +import Data.JSTarget.Traversal +import Control.Applicative +import qualified Data.Map as M +import qualified Data.Set as S + +-- TODO: tryTernary may inline calls that would otherwise be in tail position +-- which is something we'd really like to avoid. + +optimizeFun :: Var -> AST Exp -> AST Exp +optimizeFun f (AST ast js) = + flip runTravM js $ do + shrinkCase ast + >>= inlineAssigns True + >>= inlineReturns + >>= tailLoopify f + +topLevelInline :: AST Stm -> AST Stm +topLevelInline (AST ast js) = runTravM (inlineAssigns False ast) js + +-- | Attempt to turn two case branches into a ternary operator expression. +tryTernary :: Var + -> AST Exp + -> AST Exp + -> (AST Stm -> AST Stm) + -> [(AST Exp, AST Stm -> AST Stm)] + -> Maybe (AST Exp) +tryTernary self scrut retEx def [(m, alt)] = + case runTravM opt allJumps of + AST (Just ex) js -> Just (AST ex js) + _ -> Nothing + where + selfOccurs (Exp (Var v)) = v == self + selfOccurs _ = False + def' = def $ Return <$> retEx + alt' = alt $ Return <$> retEx + AST _ allJumps = scrut >> m >> def' >> alt' + opt = do + -- Make sure the return expression is used somewhere, then cut away all + -- useless assignments. If what's left is a single Return statement, + -- we have a pure expression suitable for use with ?:. + def'' <- inlineAssignsLocal $ astCode def' + alt'' <- inlineAssignsLocal $ astCode alt' + -- If self occurs in either branch, we can't inline or we risk ruining + -- tail call elimination. + selfInDef <- occurrences (const True) selfOccurs def'' + selfInAlt <- occurrences (const True) selfOccurs alt'' + case (selfInDef + selfInAlt, def'', alt'') of + (Never, Return el, Return th) -> + return $ Just $ IfEx (BinOp Eq (astCode scrut) (astCode m)) th el + _ -> + return Nothing +tryTernary _ _ _ _ _ = + Nothing + +-- | How many times does an expression satisfying the given predicate occur in +-- an AST (including jumps)? +occurrences :: JSTrav ast + => (ASTNode -> Bool) + -> (ASTNode -> Bool) + -> ast + -> TravM Occs +occurrences tr p ast = + foldJS trav count Never ast + where + trav n node = tr node && n < Lots -- Stop traversal if we're already >1. + count n node | p node = pure $ n + Once + count n _ = pure n + +-- | Replace all occurrences of an expression, without entering shared code +-- paths. IO ordering is preserved even when entering lambdas thanks to +-- State# RealWorld. +replaceEx :: JSTrav ast => (ASTNode -> Bool) -> Exp -> Exp -> ast -> TravM ast +replaceEx trav old new = + mapJS trav (\x -> if x == old then pure new else pure x) pure + +-- | Inline assignments where the assignee is only ever used once. +-- Does not inline anything into a shared code path, as that would break +-- things horribly. +-- Ignores LhsExp assignments, since we only introduce those when we actually +-- care about the assignment side effect. +inlineAssigns :: JSTrav ast => Bool -> ast -> TravM ast +inlineAssigns blackholeOK ast = do + inlinable <- gatherInlinable ast + mapJS (const True) return (inl inlinable) ast + where + varOccurs lhs (Exp (Var lhs')) = lhs == lhs' + varOccurs _ _ = False + inl m keep@(Assign (NewVar mayReorder lhs) ex next) = do + occursRec <- occurrences (const True) (varOccurs lhs) ex + if occursRec == Never + then do + occursLocal <- occurrences (not <$> isShared) (varOccurs lhs) next + case M.lookup lhs m of + Just occ | occ == occursLocal -> + case occ of + -- Never-used symbols don't need assignment. + Never | blackholeOK -> do + return (Assign blackHole ex next) + -- Inline of any non-lambda value + Once | mayReorder -> do + replaceEx (not <$> isShared) (Var lhs) ex next + -- Don't inline lambdas, but use less verbose syntax. + _ | Fun Nothing vs body <- ex, + Internal lhsname _ <- lhs -> do + return $ Assign blackHole (Fun (Just lhsname) vs body) next + _ -> do + return keep + _ -> + return keep + else do + return keep + inl _ stm = return stm + +-- | Gather a map of all inlinable symbols; that is, the once that are used +-- exactly once. +gatherInlinable :: JSTrav ast => ast -> TravM (M.Map Var Occs) +gatherInlinable = + fmap (M.filter (< Lots)) . foldJS (\_ _ -> True) countOccs M.empty + where + updVar (Just occs) = Just (occs+Once) + updVar _ = Just Once + updVarAss (Just o) = Just o + updVarAss _ = Just Never + countOccs m (Exp (Var v@(Internal _ _))) = + pure $ M.alter updVar v m + countOccs m (Stm (Assign (NewVar _ v) _ _)) = + pure $ M.alter updVarAss v m + countOccs m _ = + pure m + +-- | Like `inlineAssigns`, but doesn't care what happens beyond a jump. +inlineAssignsLocal :: JSTrav ast => ast -> TravM ast +inlineAssignsLocal ast = do + mapJS (\n -> not (isLambda n || isShared n)) return inl ast + where + varOccurs lhs (Exp (Var lhs')) = lhs == lhs' + varOccurs _ _ = False + inl keep@(Assign (NewVar mayReorder lhs) ex next) = do + occurs <- occurrences (const True) (varOccurs lhs) next + occurs' <- occurrences (const True) (varOccurs lhs) ex + case occurs + occurs' of + Never -> + return (Assign blackHole ex next) + -- Don't inline lambdas at the moment, but use less verbose syntax. + _ | Fun Nothing vs body <- ex, + Internal lhsname _ <- lhs -> + return $ Assign blackHole (Fun (Just lhsname) vs body) next + Once | mayReorder -> + -- can't be recursive - inline + replaceEx (not <$> isShared) (Var lhs) ex next + _ -> + -- Really nothing to be done here. + return keep + inl stm = return stm + +-- | Turn sequences like `v0 = foo; v1 = v0; v2 = v1; return v2;` into a +-- straightforward `return foo;`. +-- Ignores LhsExp assignments, since we only introduce those when we actually +-- care about the assignment side effect. +inlineReturns :: JSTrav ast => ast -> TravM ast +inlineReturns ast = do + (s, ast') <- foldMapJS (\_ _ -> True) pure2 foldRet S.empty ast + mapM_ (flip putRef NullRet) $ S.toList s + return ast' + where + pure2 s x = pure (s,x) + foldRet s (Assign (NewVar _ lhs) rhs (Return (Var v))) | v == lhs = do + return (s, Return rhs) + foldRet s keep@(Assign (NewVar _ lhs) rhs (Jump (Shared lbl))) = do + next <- getRef lbl + case next of + Return (Var v) | v == lhs -> + return (S.insert lbl s, Return rhs) + _ -> + return (s, keep) + foldRet s keep = do + return (s, keep) + +-- | Inline all occurrences of the given shared code path. +-- Use with caution - preferrably not at all! +inlineShared :: JSTrav ast => Lbl -> ast -> TravM ast +inlineShared lbl = + mapJS (const True) pure inl + where + inl (Jump (Shared lbl')) | lbl == lbl' = getRef lbl + inl s = pure s + +-- | Shrink case statements as much as possible. +shrinkCase :: JSTrav ast => ast -> TravM ast +shrinkCase = + mapJS (const True) pure shrink + where + shrink (Case _ def [] next@(Shared lbl)) + | def == Jump next = getRef lbl + | otherwise = inlineShared lbl def + shrink stm = return stm + +-- | Turn tail recursion on the given var into a loop, if possible. +-- Tail recursive functions that create closures turn into: +-- function f(a', b', c') { +-- while(1) { +-- var r = (function(a, b, c) { +-- a' = a; b' = b; c' = c; +-- })(a', b', c'); +-- if(r != null) { +-- return r; +-- } +-- } +-- } +tailLoopify :: Var -> Exp -> TravM Exp +tailLoopify f fun@(Fun mname args body) = do + tailrecs <- occurrences (not <$> isLambda) isTailRec body + if tailrecs > Never + then do + needToCopy <- createsClosures body + case needToCopy of + True -> do + let args' = map newName args + ret = Return (Lit $ LNull) + b <- mapJS (not <$> isLambda) pure (replaceByAssign ret args') body + let (AST nullRetLbl _) = lblFor NullRet + nn = newName f + nv = NewVar False nn + body' = + Forever $ + Assign nv (Call 0 Fast (Fun Nothing args b) (map Var args'))$ + Case (Var nn) (Return (Var nn)) [(Lit $ LNull, NullRet)] $ + (Shared nullRetLbl) + putRef nullRetLbl NullRet + return $ Fun mname args' body' + False -> do + let c = Cont + body' <- mapJS (not <$> isLambda) pure (replaceByAssign c args) body + return $ Fun mname args (Forever body') + else do + return fun + where + isTailRec (Stm (Return (Call 0 _ (Var f') _))) = f == f' + isTailRec _ = False + + -- Only traverse until we find a closure + createsClosures = foldJS (\acc _ -> not acc) isClosure False + isClosure _ (Exp (Fun _ _ _)) = pure True + isClosure acc _ = pure acc + + -- Assign any changed vars, then loop. + replaceByAssign end as (Return (Call 0 _ (Var f') as')) | f == f' = do + let (first, second) = foldr assignUnlessEqual (id, end) (zip as as') + return $ first second + replaceByAssign _ _ stm = + return stm + + -- Assign an expression to a variable, unless that expression happens to + -- be the variable itself. + assignUnlessEqual (v, (Var v')) (next, final) | v == v' = + (next, final) + assignUnlessEqual (v, x) (next, final) | any (x `contains`) args = + (Assign (NewVar False (newName v)) x . next, + Assign (LhsExp (Var v)) (Var $ newName v) final) + | otherwise = + (Assign (LhsExp (Var v)) x . next, final) + + newName (Internal (Name n mmod) _) = + Internal (Name (' ':n) mmod) "" + newName n = + n + + contains (Var v) var = v == var + contains (Lit _) _ = False + contains (Not x) var = x `contains` var + contains (BinOp _ a b) var = a `contains` var || b `contains` var + contains (Fun _ _ _) _ = False + contains (Call _ _ f' xs) var = f' `contains` var||any (`contains` var) xs + contains (Index a i) var = a `contains` var || i `contains` var + contains (Arr xs) var = any (`contains` var) xs + contains (AssignEx l r) var = l `contains` var || r `contains` var + contains (IfEx c t e) var = any (`contains` var) [c,t,e] +tailLoopify _ fun = do + return fun diff --git a/src/Data/JSTarget/PP.hs b/src/Data/JSTarget/PP.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSTarget/PP.hs @@ -0,0 +1,196 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, + GeneralizedNewtypeDeriving #-} +-- | JSTarget pretty printing machinery. The actual printing happens in +-- Data.JSTarget.Print. +module Data.JSTarget.PP where +import Data.Default +import Data.Monoid +import Data.String +import Data.List (foldl') +import Data.Array +import Control.Monad +import Control.Applicative +import qualified Data.Map as M +import qualified Data.ByteString.Lazy as BS +import Data.ByteString.Lazy.Builder +import Data.ByteString.Lazy.Builder.ASCII +import Data.JSTarget.AST (AST (..), Name (..), JumpTable, Lbl, Stm) +import Data.JSTarget.Traversal (JSTrav) + +-- | Pretty-printing options +data PPOpts = PPOpts { + nameComments :: Bool, -- ^ Emit comments for names, where available? + useIndentation :: Bool, -- ^ Should we indent at all? + indentStr :: Builder, -- ^ String to use for each step of indentation + useNewlines :: Bool, -- ^ Use line breaks? + useSpaces :: Bool -- ^ Use spaces other than where necessary? + } + +type IndentLvl = Int + +-- | Final name for symbols. This name is what actually appears in the final +-- JS dump, albeit "base 62"-encoded. +newtype FinalName = FinalName Int deriving (Ord, Eq, Enum, Show) +type NameSupply = (FinalName, M.Map Name FinalName) + +emptyNS :: NameSupply +emptyNS = (FinalName 0, M.empty) + +newtype PP a = PP {unPP :: PPOpts + -> IndentLvl + -> NameSupply + -> JumpTable + -> Builder + -> (NameSupply, Builder, a)} + +instance Monad PP where + PP m >>= f = PP $ \opts indentlvl ns js b -> + case m opts indentlvl ns js b of + (ns', b', x) -> unPP (f x) opts indentlvl ns' js b' + return x = PP $ \_ _ ns _ b -> (ns, b, x) + +instance Applicative PP where + pure = return + (<*>) = ap + +instance Functor PP where + fmap f p = p >>= return . f + +-- | Convenience operator for using the PP () IsString instance. +(.+.) :: PP () -> PP () -> PP () +(.+.) = (>>) +infixl 1 .+. + +instance Default PPOpts where + def = PPOpts { + nameComments = False, + useIndentation = False, + indentStr = " ", + useNewlines = False, + useSpaces = False + } + +debugPPOpts :: PPOpts +debugPPOpts = def { + nameComments = True, + useIndentation = True, + indentStr = " ", + useNewlines = True, + useSpaces = True + } + +-- | Generate the final name for a variable. +finalNameFor :: Name -> PP FinalName +finalNameFor n = PP $ \_ _ ns@(nextN, m) _ b -> + case M.lookup n m of + Just n' -> (ns, b, n') + _ -> ((succ nextN, M.insert n nextN m), b, nextN) + +-- | Look up a shared reference. +lookupLabel :: Lbl -> PP Stm +lookupLabel lbl = PP $ \_ _ ns js b -> (ns, b, js M.! lbl) + +-- | Returns the value of the given pretty-printer option. +getOpt :: (PPOpts -> a) -> PP a +getOpt f = PP $ \opts _ ns _ b -> (ns, b, f opts) + +-- | Runs the given printer iff the specifiet option is True. +whenOpt :: (PPOpts -> Bool) -> PP () -> PP () +whenOpt f p = getOpt f >>= \x -> when x p + +-- | Pretty print an AST. +pretty :: (JSTrav a, Pretty a) => PPOpts -> AST a -> BS.ByteString +pretty opts (AST ast js) = + case runPP opts js (pp ast) of + (b, _) -> toLazyByteString b + +-- | Run a pretty printer. +runPP :: PPOpts -> JumpTable -> PP a -> (Builder, a) +runPP opts js p = + case unPP p opts 0 emptyNS js mempty of + (_, b, x) -> (b, x) + +-- | Pretty-print a program and return the final name for its entry point. +prettyProg :: Pretty a => PPOpts -> Name -> AST a -> (Builder, Builder) +prettyProg opts mainSym (AST ast js) = runPP opts js $ do + pp ast + buildFinalName <$> finalNameFor mainSym + +-- | Turn a FinalName into a Builder. +buildFinalName :: FinalName -> Builder +buildFinalName (FinalName 0) = + string7 "_0" +buildFinalName (FinalName fn) = + char7 '_' <> go fn mempty + where + arrLen = 62 + chars = listArray (0,arrLen-1) + $ "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + go 0 acc = acc + go n acc = let (rest, ix) = n `quotRem` arrLen + in go rest (char7 (chars ! ix) <> acc) + +-- | Indent the given builder another step. +indent :: PP a -> PP a +indent (PP p) = PP $ \opts indentlvl ns b -> + if useIndentation opts + then p opts (indentlvl+1) ns b + else p opts 0 ns b + +class Buildable a where + put :: a -> PP () + +instance Buildable Builder where + put x = PP $ \_ _ ns _ b -> (ns, b <> x, ()) +instance Buildable String where + put = put . stringUtf8 +instance Buildable Char where + put = put . char7 +instance Buildable Int where + put = put . intDec +instance Buildable Double where + put d = + case round d of + n | fromIntegral n == d -> put $ intDec n + | otherwise -> put $ doubleDec d +instance Buildable Integer where + put = put . integerDec +instance Buildable Bool where + put x = put $ if x then string7 "true" else string7 "false" + +-- | Emit indentation up to the current level. +ind :: PP () +ind = PP $ \opts indentlvl ns _ b -> + (ns, foldl' (<>) b (replicate indentlvl (indentStr opts)), ()) + +-- | A space character. +sp :: PP () +sp = whenOpt useSpaces $ put ' ' + +-- | A newline character. +newl :: PP () +newl = whenOpt useNewlines $ put '\n' + +-- | Indent the given builder and terminate it with a newline. +line :: PP () -> PP () +line p = do + ind >> p + whenOpt useNewlines $ put '\n' + +-- | Pretty print a list with the given separator. +ppList :: Pretty a => PP () -> [a] -> PP () +ppList sep (x:xs) = + foldl' (\l r -> l >> sep >> pp r) (pp x) xs +ppList _ _ = + return () + +instance IsString Builder where + fromString = stringUtf8 + +instance IsString (PP ()) where + fromString = put . stringUtf8 + +-- | Pretty-printer class. Each part of the AST needs an instance of this. +class Pretty a where + pp :: a -> PP () diff --git a/src/Data/JSTarget/Print.hs b/src/Data/JSTarget/Print.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSTarget/Print.hs @@ -0,0 +1,204 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, GADTs, OverloadedStrings #-} +module Data.JSTarget.Print () where +import Prelude hiding (LT, GT) +import Data.JSTarget.AST +import Data.JSTarget.Op +import Data.JSTarget.PP as PP +import Data.ByteString.Lazy.Builder +import Data.Monoid +import Control.Monad + +instance Pretty Var where + pp (Foreign name) = + put $ string7 name + pp (Internal name comment) = do + pp name + doComment <- getOpt nameComments + when (doComment && not (null comment)) $ + put $ "/* " <> stringUtf8 comment <> " */" + +instance Pretty Name where + pp name = finalNameFor name >>= put . buildFinalName + +instance Pretty LHS where + pp (NewVar _ v) = "var " .+. pp v + pp (LhsExp ex) = pp ex + +instance Pretty Lit where + pp (LNum d) = put d + pp (LStr s) = "\"" .+. put (fixQuotes s) .+. "\"" + where + fixQuotes ('\\':'x':xs) = '\\':'x' : fixQuotes xs + fixQuotes ('\\':'u':xs) = '\\':'u' : fixQuotes xs + fixQuotes ('\\':xs) = '\\':'\\' : fixQuotes xs + fixQuotes ('"':xs) = '\\':'"' : fixQuotes xs + fixQuotes ('\'':xs) = '\\':'\'' : fixQuotes xs + fixQuotes ('\n':xs) = '\\':'n' : fixQuotes xs + fixQuotes (x:xs) = x : fixQuotes xs + fixQuotes _ = [] + pp (LBool b) = put b + pp (LInt n) = put n + pp (LNull) = "null" + +-- | Default separator; comma followed by space, if spaces are enabled. +sep :: PP () +sep = "," .+. sp + +instance Pretty Exp where + pp (Var v) = + pp v + pp (Lit l) = + pp l + pp (Not ex) = + case neg ex of + Just ex' -> pp ex' + _ -> if expPrec (Not ex) > expPrec ex + then "!(" .+. pp ex .+. ")" + else "!" .+. pp ex + pp (BinOp op a b) = + opParens op a b + pp (Fun mname args body) = do + "function" .+. lambdaname .+. "(" .+. ppList sep args .+. "){" .+. newl + indent $ pp body + ind .+. "}" + where + lambdaname = maybe "" (\n -> " " .+. pp n) mname + pp (Call _ call f args) = do + case call of + Normal -> "A(" .+. pp f .+. ",[" .+. ppList sep args .+. "])" + Fast -> ppCallFun f .+. "(" .+. ppList sep args .+. ")" + Method m -> pp f .+. put ('.':m) .+. "(" .+. ppList sep args .+. ")" + where + ppCallFun fun@(Fun _ _ _) = "(" .+. pp fun .+. ")" + ppCallFun fun = pp fun + pp (Index arr ix) = do + pp arr .+. "[" .+. pp ix .+. "]" + pp (Arr exs) = do + "[" .+. ppList sep exs .+. "]" + pp (AssignEx l r) = do + pp l .+. sp .+. "=" .+. sp .+. pp r + pp (IfEx c th el) = do + pp c .+. sp .+. "?" .+. sp .+. pp th .+. sp .+. ":" .+. sp .+. pp el + +instance Pretty (Var, Exp) where + pp (v, ex) = pp v .+. sp .+. "=" .+. sp .+. pp ex + +-- | Print a series of NewVars at once, to avoid unnecessary "var" keywords. +ppAssigns :: Stm -> PP () +ppAssigns stm = do + line $ "var " .+. ppList sep assigns .+. ";" + pp next + where + (assigns, next) = gather [] stm + gather as (Assign (NewVar _ v) ex nxt) = gather ((v, ex):as) nxt + gather as nxt = (reverse as, nxt) + +-- | Returns the final statement in a case branch. +finalStm :: Stm -> PP Stm +finalStm s = + case s of + Assign _ _ s' -> finalStm s' + Case _ _ _ (Shared l) -> lookupLabel l >>= finalStm + Forever s' -> finalStm s' + _ -> return s + +instance Pretty Stm where + pp (Case cond def alts (Shared nextRef)) = do + prettyCase cond def alts + lookupLabel nextRef >>= pp + pp (Forever stm) = do + line "while(1){" + indent $ pp stm + line "}" + pp s@(Assign lhs ex next) = do + case lhs of + _ | lhs == blackHole -> + line (pp ex .+. ";") >> pp next + NewVar _ _ -> + ppAssigns s + LhsExp _ -> + line (pp lhs .+. sp .+. "=" .+. sp .+. pp ex .+. ";") >> pp next + pp (Return ex) = do + line $ "return " .+. pp ex .+. ";" + pp (Cont) = do + line "continue;" + pp (Jump _) = do + -- Jumps are essentially fallthroughs which keep track of their + -- continuation to make analysis and optimization easier. + return () + pp (NullRet) = do + return () + +neg :: Exp -> Maybe Exp +neg (BinOp Eq a b) = Just $ BinOp Neq a b +neg (BinOp Neq a b) = Just $ BinOp Eq a b +neg (BinOp GT a b) = Just $ BinOp LTE a b +neg (BinOp LT a b) = Just $ BinOp GTE a b +neg (BinOp GTE a b) = Just $ BinOp LT a b +neg (BinOp LTE a b) = Just $ BinOp GT a b +neg _ = Nothing + +-- | Turn eligible case statements into if statements. +prettyCase :: Exp -> Stm -> [Alt] -> PP () +prettyCase cond def [(con, branch)] = do + case (def, branch) of + (_, NullRet) -> do + line $ "if(" .+. pp (neg' (test con)) .+. "){" + indent $ pp def + line "}" + (NullRet, _) -> do + line $ "if(" .+. pp (test con) .+. "){" + indent $ pp branch + line "}" + _ -> do + line $ "if(" .+. pp (test con) .+."){" + indent $ pp branch + line "}else{" + 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 +prettyCase _ def [] = do + pp def +prettyCase cond def alts = do + line $ "switch(" .+. pp cond .+. "){" + indent $ do + mapM_ pp alts + line $ "default:" + indent $ pp def + line "}" + +instance Pretty Alt where + pp (con, branch) = do + line $ "case " .+. pp con .+. ":" + indent $ do + pp branch + s <- finalStm branch + case s of + Return _ -> return () + Cont -> return () + _ -> line "break;"; + +opParens :: BinOp -> Exp -> Exp -> PP () +opParens Sub a (BinOp Sub (Lit (LNum 0)) b) = + opParens Add a b +opParens Sub a (Lit (LNum n)) | n < 0 = + opParens Add a (Lit (LNum (-n))) +opParens Sub (Lit (LNum 0)) b = + case b of + BinOp _ _ _ -> "-(" .+. pp b .+. ")" + _ -> "-" .+. pp b +opParens op a b = do + let bparens = case b of + Lit (LNum n) | n < 0 -> \x -> "(".+. pp x .+. ")" + _ -> parens + parens a >> put (string7 $ show op) >> bparens b + where + parens x = if expPrec x < opPrec op + then "(" .+. pp x .+. ")" + else pp x diff --git a/src/Data/JSTarget/Traversal.hs b/src/Data/JSTarget/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSTarget/Traversal.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE FlexibleInstances, TupleSections, PatternGuards #-} +-- | Generic traversal of JSTarget AST types. +module Data.JSTarget.Traversal where +import Control.Applicative +import Control.Monad +import Data.JSTarget.AST +import Data.Map as M ((!), insert) + +-- | AST nodes we'd like to fold and map over. +data ASTNode = Exp Exp | Stm Stm | Label Lbl + +newtype TravM a = T (JumpTable -> (JumpTable, a)) +instance Monad TravM where + return x = T $ \js -> (js, x) + T m >>= f = T $ \js -> + case m js of + (js', x) | T f' <- f x -> f' js' + +instance Applicative TravM where + pure = return + (<*>) = ap + +instance Functor TravM where + fmap f (T m) = T $ \js -> fmap f (m js) + +runTravM :: TravM a -> JumpTable -> AST a +runTravM (T f) js = case f js of (js', x) -> AST x js' + +getRef :: Lbl -> TravM Stm +getRef lbl = T $ \js -> (js, js M.! lbl) + +putRef :: Lbl -> Stm -> TravM () +putRef lbl stm = T $ \js -> (M.insert lbl stm js, ()) + +class Show ast => JSTrav ast where + -- | Bottom up transform over an AST. + foldMapJS :: (a -> ASTNode -> Bool) -- ^ Enter node? + -> (a -> Exp -> TravM (a, Exp)) -- ^ Exp to Exp mapping. + -> (a -> Stm -> TravM (a, Stm)) -- ^ Stm to Stm mapping. + -> a -- ^ Starting accumulator. + -> ast -- ^ AST to map over. + -> TravM (a, ast) + + -- | Bottom up fold of an AST. + foldJS :: (a -> ASTNode -> Bool) -- ^ Should the given node be entered? + -- The step function is always applied + -- to the current node, however. + -> (a -> ASTNode -> TravM a) -- ^ Step function. + -> a -- ^ Initial value. + -> ast -- ^ AST to fold over. + -> TravM a + +mapJS :: JSTrav ast + => (ASTNode -> Bool) + -> (Exp -> TravM Exp) + -> (Stm -> TravM Stm) + -> ast + -> TravM ast +mapJS tr fe fs ast = + snd <$> foldMapJS (const tr) (const' fe) (const' fs) () ast + where + const' f _ x = ((),) <$> f x + +instance JSTrav a => JSTrav [a] where + foldMapJS tr fe fs acc ast = + go (acc, []) ast + where + go (a, xs') (x:xs) = do + (a', x') <- foldMapJS tr fe fs a x + go (a', x':xs') xs + go (a, xs) _ = do + return (a, reverse xs) + foldJS tr f acc ast = foldM (foldJS tr f) acc ast + +instance JSTrav Exp where + foldMapJS tr fe fs acc ast = do + (acc', x) <- if tr acc (Exp ast) + then do + case ast of + v@(Var _) -> do + pure (acc, v) + l@(Lit _) -> do + pure (acc, l) + Not ex -> do + fmap Not <$> mapEx acc ex + BinOp op a b -> do + (acc', a') <- mapEx acc a + (acc'', b') <- mapEx acc' b + return (acc'', BinOp op a' b') + Fun nam vs stm -> do + fmap (Fun nam vs) <$> foldMapJS tr fe fs acc stm + Call ar c f xs -> do + (acc', f') <- mapEx acc f + (acc'', xs') <- foldMapJS tr fe fs acc' xs + return (acc'', Call ar c f' xs') + Index arr ix -> do + (acc', arr') <- mapEx acc arr + (acc'', ix') <- mapEx acc' ix + return (acc'', Index arr' ix') + Arr exs -> do + fmap Arr <$> foldMapJS tr fe fs acc exs + AssignEx l r -> do + (acc', l') <- mapEx acc l + (acc'', r') <- mapEx acc' r + return (acc'', AssignEx l' r') + IfEx c th el -> do + (acc', c') <- mapEx acc c + (acc'', th') <- mapEx acc' th + (acc''', el') <- mapEx acc'' el + return (acc''', IfEx c' th' el') + else do + return (acc, ast) + fe acc' x + where + mapEx = foldMapJS tr fe fs + + foldJS tr f acc ast = do + let expast = Exp ast + acc' <- if tr acc expast + then do + case ast of + Var _ -> do + return acc + Lit _ -> do + return acc + Not ex -> do + foldJS tr f acc ex + BinOp _ a b -> do + acc' <- foldJS tr f acc a + foldJS tr f acc' b + Fun _ _ stm -> do + foldJS tr f acc stm + Call _ _ fun xs -> do + acc' <- foldJS tr f acc fun + foldJS tr f acc' xs + Index arr ix -> do + acc' <- foldJS tr f acc arr + foldJS tr f acc' ix + Arr exs -> do + foldJS tr f acc exs + AssignEx l r -> do + acc' <- foldJS tr f acc l + foldJS tr f acc' r + IfEx c th el -> do + acc' <- foldJS tr f acc c + acc'' <- foldJS tr f acc' th + foldJS tr f acc'' el + else do + return acc + f acc' expast + +instance JSTrav Stm where + foldMapJS tr fe fs acc ast = do + (acc', x) <- if tr acc (Stm ast) + then do + case ast of + Case ex def alts next -> do + (acc', ex') <- foldMapJS tr fe fs acc ex + (acc'', def') <- foldMapJS tr fe fs acc' def + (acc''', alts') <- foldMapJS tr fe fs acc'' alts + (acc'''', next') <- foldMapJS tr fe fs acc''' next + return (acc'''', Case ex' def' alts' next') + Forever stm -> do + fmap Forever <$> foldMapJS tr fe fs acc stm + Assign lhs ex next -> do + (acc', lhs') <- foldMapJS tr fe fs acc lhs + (acc'', ex') <- foldMapJS tr fe fs acc' ex + (acc''', next') <- foldMapJS tr fe fs acc'' next + return (acc''', Assign lhs' ex' next') + Return ex -> do + fmap Return <$> foldMapJS tr fe fs acc ex + Cont -> do + return (acc, Cont) + Jump stm -> do + fmap Jump <$> foldMapJS tr fe fs acc stm + NullRet -> do + return (acc, NullRet) + else do + return (acc, ast) + fs acc' x + + foldJS tr f acc ast = do + let stmast = Stm ast + acc' <- if tr acc stmast + then do + case ast of + Case ex def alts next -> do + acc' <- foldJS tr f acc ex + acc'' <- foldJS tr f acc' def + acc''' <- foldJS tr f acc'' alts + foldJS tr f acc''' next + Forever stm -> do + foldJS tr f acc stm + Assign lhs ex next -> do + acc' <- foldJS tr f acc lhs + acc'' <- foldJS tr f acc' ex + foldJS tr f acc'' next + Return ex -> do + foldJS tr f acc ex + Cont -> do + return acc + Jump j -> do + foldJS tr f acc j + NullRet -> do + return acc + else do + return acc + f acc' stmast + +instance JSTrav (Exp, Stm) where + foldMapJS tr fe fs acc (ex, stm) = do + (acc', stm') <- foldMapJS tr fe fs acc stm + (acc'', ex') <- foldMapJS tr fe fs acc' ex + return (acc'', (ex', stm')) + foldJS tr f acc (ex, stm) = do + acc' <- foldJS tr f acc stm + foldJS tr f acc' ex + +instance JSTrav LHS where + foldMapJS _ _ _ acc lhs@(NewVar _ _) = return (acc, lhs) + foldMapJS t fe fs a (LhsExp ex) = fmap LhsExp <$> foldMapJS t fe fs a ex + foldJS _ _ acc (NewVar _ _) = return acc + foldJS tr f acc (LhsExp ex) = foldJS tr f acc ex + +instance JSTrav a => JSTrav (Shared a) where + foldMapJS tr fe fs acc sh@(Shared lbl) = do + if (tr acc (Label lbl)) + then do + stm <- getRef lbl + (acc', stm') <- foldMapJS tr fe fs acc stm + putRef lbl stm' + return (acc', sh) + else do + return (acc, sh) + foldJS tr f acc (Shared lbl) = do + if (tr acc (Label lbl)) + then getRef lbl >>= foldJS tr f acc >>= \acc' -> f acc' (Label lbl) + else f acc (Label lbl) + +class Pred a where + (.|.) :: a -> a -> a + (.&.) :: a -> a -> a + +instance Pred (a -> b -> Bool) where + p .|. q = \a b -> p a b || q a b + p .&. q = \a b -> p a b && q a b + +instance Pred (a -> Bool) where + p .|. q = \a -> p a || q a + p .&. q = \a -> p a && q a + +isShared :: ASTNode -> Bool +isShared (Label _) = True +isShared _ = False + +isLambda :: ASTNode -> Bool +isLambda (Exp (Fun _ _ _)) = True +isLambda _ = False + +-- | Counts occurrences. Use ints or something for a more exact count. +data Occs = Never | Once | Lots deriving (Eq, Show) + +instance Ord Occs where + compare Never Once = Prelude.LT + compare Never Lots = Prelude.LT + compare Once Lots = Prelude.LT + compare a b = if a == b then Prelude.EQ else Prelude.GT + +instance Num Occs where + fromInteger n | n <= 0 = Never + | n == 1 = Once + | otherwise = Lots + Never + x = x + x + Never = x + _ + _ = Lots + + Never * _ = Never + _ * Never = Never + Once * x = x + x * Once = x + _ * _ = Lots + + abs = id + + signum Never = Never + signum _ = Once diff --git a/src/Haste.hs b/src/Haste.hs new file mode 100644 --- /dev/null +++ b/src/Haste.hs @@ -0,0 +1,8 @@ +module Haste ( + module Linker, module Config, module CodeGen, + Fingerprint, Module, writeModule, readModule, readModuleFingerprint) where +import Haste.Linker as Linker +import Haste.Config as Config +import Haste.Module +import Haste.CodeGen as CodeGen +import Data.JSTarget.AST (Fingerprint, Module) diff --git a/src/Haste/Builtins.hs b/src/Haste/Builtins.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Builtins.hs @@ -0,0 +1,43 @@ +-- | Various functions generated as builtins +module Haste.Builtins (toBuiltin) where +import GhcPlugins as P +import Data.JSTarget as J +import Control.Applicative + +toBuiltin :: P.Var -> Maybe J.Var +toBuiltin v = + case (modname, varname) of + (Just "GHC.Prim", "coercionToken#") -> + Just $ foreignVar "coercionToken" + (Just "GHC.Prim", "realWorld#") -> + Just $ foreignVar "realWorld" + (Just "GHC.Err", "error") -> + Just $ foreignVar "err" + + -- Everything to do with unpacking had better be built in for compactness, + -- efficiency and space reasons. + (Just "GHC.CString", "unpackCString#") -> + Just $ foreignVar "unCStr" + (Just "GHC.CString", "unpackCStringUtf8#") -> + Just $ foreignVar "unCStr" + (Just "GHC.CString", "unpackAppendCString#") -> + Just $ foreignVar "unAppCStr" + (Just "GHC.CString", "unpackFoldrCString#") -> + Just $ foreignVar "unFoldrCStr" + + -- Primitive needs of the Haste standard library + (Just "Haste.Prim", "toJSStr") -> + Just $ foreignVar "toJSStr" + (Just "Haste.Prim", "fromJSStr") -> + Just $ foreignVar "fromJSStr" + (Just "Haste.Prim", "jsRound") -> + Just $ foreignVar "Math.round" + (Just "Haste.Prim", "jsCeiling") -> + Just $ foreignVar "Math.ceil" + (Just "Haste.Prim", "jsFloor") -> + Just $ foreignVar "Math.floor" + _ | otherwise -> + Nothing + where + modname = moduleNameString . moduleName <$> nameModule_maybe (varName v) + varname = occNameString $ nameOccName $ varName v diff --git a/src/Haste/CodeGen.hs b/src/Haste/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Haste/CodeGen.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE TupleSections, PatternGuards #-} +module Haste.CodeGen (generate) where +-- Misc. stuff +import Control.Applicative +import Control.Monad +import Data.Int +import Data.Word +import Data.Char +import Data.List (partition, foldl') +import Data.Maybe (isJust) +import qualified Data.Set as S +import qualified Data.Map as M +-- STG/GHC stuff +import StgSyn +import CoreSyn (AltCon (..)) +import Var (Var, varType, varName) +import IdInfo (arityInfo, IdDetails (..)) +import Id (Id, idInfo, idDetails, isLocalId, isGlobalId) +import Literal as L +import FastString (unpackFS, FastString) +import ForeignCall (CCallTarget (..), ForeignCall (..), CCallSpec (..)) +import PrimOp (PrimCall (..)) +import OccName +import DataCon +import Module +import Name +import Type +import TysPrim +import TyCon +import BasicTypes +-- AST stuff +import Data.JSTarget as J +import Data.JSTarget.AST (Exp (..), Stm (..), LHS (..), Lit (..)) +-- General Haste stuff +import Haste.Config +import Haste.Monad +import Haste.Errors +import Haste.PrimOps +import Haste.Builtins +import Haste.Util (showOutputable) + +generate :: Config + -> Fingerprint + -> String + -> ModuleName + -> [StgBinding] + -> J.Module +generate cfg fp pkgid modname binds = + Module { + modFingerprint = fp, + modPackageId = pkgid, + modName = moduleNameString modname, + modDeps = foldl' insDep M.empty theMod, + modDefs = foldl' insFun M.empty theMod + } + where + theMod = genAST cfg modname binds + + insFun m (_, AST (Assign (NewVar _ (Internal v _)) body _) jumps) = + M.insert v (AST body jumps) m + insFun m _ = + m + + -- TODO: perhaps do dependency-based linking for externals as well? + insDep m (ds, AST (Assign (NewVar _ (Internal v _)) _ _) _) = + M.insert v (S.delete v ds) m + insDep m _ = + m + +-- | Generate JS AST for bindings. +genAST :: Config -> ModuleName -> [StgBinding] -> [(S.Set J.Name, AST Stm)] +genAST cfg modname binds = + binds' + where + binds' = + map (depsAndCode . genJS cfg myModName . uncurry (genBind True)) + $ concatMap unRec + $ binds + myModName = moduleNameString modname + depsAndCode (_, ds, locs, stm) = (ds S.\\ locs, stm nullRet) + +-- | Generate code for an STG expression. +genEx :: StgExpr -> JSGen Config (AST Exp) +genEx (StgApp f xs) = do + genApp f xs +genEx (StgLit l) = do + genLit l +genEx (StgConApp con args) = do + (tag, stricts) <- genDataCon con + (args', stricts') <- genArgsPair $ zip args stricts + -- Don't create unboxed tuples with a single element. + case (isUnboxedTupleCon con, args') of + (True, [arg]) -> return $ evaluate arg (head stricts') + _ -> mkCon tag args' stricts' + where + -- Always inline bools + mkCon l@(AST (Lit (LBool _)) _) _ _ = return l + mkCon tag as ss = return $ array (tag : zipWith evaluate as ss) + evaluate arg True = eval arg + evaluate arg _ = arg +genEx (StgOpApp op args _) = do + args' <- genArgs args + cfg <- getCfg + let theOp = case op of + StgPrimOp op' -> + genOp cfg op' args' + StgPrimCallOp (PrimCall f _) -> + Right $ callForeign (unpackFS f) args' + StgFCallOp (CCall (CCallSpec (StaticTarget f _ _) _ _)) _t -> + Right $ callForeign (unpackFS f) args' + _ -> + error $ "Tried to generate unsupported dynamic foreign call!" + case theOp of + Right x -> return x + Left err -> warn Normal err >> return (runtimeError err) +genEx (StgLet bind ex) = do + genBindRec bind + genEx ex +genEx (StgLetNoEscape _ _ bind ex) = do + genBindRec bind + genEx ex +genEx (StgCase ex _ _ bndr _ t alts) = do + genCase t ex bndr alts +genEx (StgSCC _ _ _ ex) = do + genEx ex +genEx (StgTick _ _ ex) = do + genEx ex +genEx (StgLam _ _) = do + error "StgLam caught during code generation - that's impossible!" + +genBindRec :: StgBinding -> JSGen Config () +genBindRec bs@(StgRec _) = do + mapM_ (genBind False (Just len) . snd) bs' + where + bs' = unRec bs + len = length bs' +genBindRec b = + genBind False Nothing b + +-- | Generate code for all bindings. genBind spits out an error if it receives +-- a recursive binding; this is because it's quite a lot easier to keep track +-- of which functions depend on each other if every genBind call results in a +-- single function being generated. +-- Use `genBindRec` to generate code for local potentially recursive bindings +-- as their dependencies get merged into their parent's anyway. +genBind :: Bool -> Maybe Int -> StgBinding -> JSGen Config () +genBind onTopLevel funsInRecGroup (StgNonRec v rhs) = do + v' <- genVar v + pushBind v' + when (not onTopLevel) $ do + addLocal v' + expr <- genRhs (isJust funsInRecGroup) rhs + popBind + let expr' = optimizeFun v' expr + continue $ newVar True v' expr' +genBind _ _ (StgRec _) = + error $ "genBind got recursive bindings!" + +-- | Generate the RHS of a binding. +genRhs :: Bool -> StgRhs -> JSGen Config (AST Exp) +genRhs recursive (StgRhsCon _ con args) = do + -- Constructors are never partially applied, and we have arguments, so this + -- is obviously a full application. + if recursive + then thunk . ret <$> genEx (StgConApp con args) + else genEx (StgConApp con args) +genRhs _ (StgRhsClosure _ _ _ upd _ args body) = do + args' <- mapM genVar args + (retExp, body') <- isolate $ do + mapM_ addLocal args' + genEx body + return $ if isUpdatable upd && null args + then thunk' (body' $ ret retExp) + else fun args' (body' $ ret retExp) + where + thunk' (AST (Return l@(Lit _)) js) = AST l js + thunk' stm = thunk stm + +-- | Turn a recursive binding into a list of non-recursive ones, together with +-- information about whether they came from a recursive group or not. +unRec :: StgBinding -> [(Maybe Int, StgBinding)] +unRec (StgRec bs) = zip (repeat len) (map (uncurry StgNonRec) bs) + where + len = Just $ length bs +unRec b = [(Nothing, b)] + +-- | Filter a list of (Var, anything) pairs, generate JSVars from the Vars +-- and then return both lists. +-- Lists of vars are often accompanied by lists of strictness or usage +-- annotations, which need to be filtered for types without representation +-- as well. +genArgVarsPair :: [(Var.Var, a)] -> JSGen Config ([J.Var], [a]) +genArgVarsPair vps = do + vs' <- mapM genVar vs + return (vs', xs) + where + (vs, xs) = unzip $ filter (hasRepresentation . fst) vps + +genCase :: AltType -> StgExpr -> Id -> [StgAlt] -> JSGen Config (AST Exp) +genCase t ex scrut alts = do + ex' <- genEx ex + -- If we have a unary unboxed tuple, we want to eliminate the case + -- entirely (modulo evaluation), so just generate the expression in the + -- sole alternative. + case (isUnaryUnboxedTuple scrut, alts) of + (True, [(_, as, _, expr)]) | [arg] <- filter hasRepresentation as -> do + arg' <- genVar arg + addLocal [arg'] + continue (newVar (reorderableType scrut) arg' ex') + genEx expr + (True, _) -> do + error "Case on unary unboxed tuple with more than one alt! WTF?!" + _ -> do + -- Generate scrutinee and result vars + scrut' <- genVar scrut + res <- genResultVar scrut + addLocal [scrut', res] + -- Split alts into default and general, and generate code for them + let (defAlt, otherAlts) = splitAlts alts + scrutinee = cmp (varExp scrut') + (_, defAlt') <- genAlt scrut' res defAlt + alts' <- mapM (genAlt scrut' res) otherAlts + -- Use the ternary operator where possible. + useSloppyTCE <- sloppyTCE `fmap` getCfg + self <- if useSloppyTCE then return blackHoleVar else getCurrentBinding + case tryTernary self scrutinee (varExp res) defAlt' alts' of + Just ifEx -> do + continue $ newVar (reorderableType scrut) scrut' ex' + continue $ newVar True res ifEx + return (varExp res) + _ -> do + continue $ newVar (reorderableType scrut) scrut' ex' + continue $ case_ scrutinee defAlt' alts' + return (varExp res) + where + getTag s = index s (litN 0) + cmp = case t of + PrimAlt _ -> id + AlgAlt tc -> if tyConIsBoolean 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. +splitAlts :: [StgAlt] -> (StgAlt, [StgAlt]) +splitAlts alts = + case partition isDefault alts of + ([defAlt], otherAlts) -> (defAlt, otherAlts) + ([], otherAlts) -> (last otherAlts, init otherAlts) + _ -> error "More than one default alt in case!" + where + isDefault (DEFAULT, _, _, _) = True + isDefault _ = False + +genAlt :: J.Var -> J.Var -> StgAlt -> JSGen Config (AST Exp,AST Stm -> AST Stm) +genAlt scrut res (con, args, used, body) = do + construct <- case con of + -- undefined is intentional here - the first element is never touched. + DEFAULT -> return (undefined, ) + LitAlt l -> (,) <$> genLit l + DataAlt c | tag <- genDataConTag c -> return (tag, ) + (args', used') <- genArgVarsPair (zip args used) + addLocal args' + let binds = [bindVar v ix | (v, True, ix) <- zip3 args' used' [1..]] + (_, body') <- isolate $ do + continue $ foldr (.) id binds + retEx <- genEx body + continue $ newVar True res retEx + return $ construct body' + where + bindVar v ix = newVar True v (index (varExp scrut) (litN ix)) + +-- | Generate a result variable for the given scrutinee variable. +genResultVar :: Var.Var -> JSGen Config J.Var +genResultVar v = (\mn -> toJSVar mn v (Just "#result")) <$> getModName + +-- | Generate a new variable and add a dependency on it to the function +-- currently being generated. +genVar :: Var.Var -> JSGen Config J.Var +genVar v | hasRepresentation v = do + case toBuiltin v of + Just v' -> return v' + _ -> do + mymod <- getModName + v' <- return $ toJSVar mymod v Nothing + dependOn v' + return v' +genVar _ = do + return $ foreignVar "_" + +-- | Extracts the name of a foreign var. +foreignName :: ForeignCall -> String +foreignName (CCall (CCallSpec (StaticTarget str _ _) _ _)) = + unpackFS str +foreignName _ = + error "Dynamic foreign calls not supported!" + +toJSVar :: String -> Var.Var -> Maybe String -> J.Var +toJSVar thisMod v msuffix = + case idDetails v of + FCallId fc -> foreignVar (foreignName fc) + _ + | isLocalId v && not hasMod -> + internalVar (name (unique ++ suffix) (Just (myPkg, myMod))) "" + | isGlobalId v || hasMod -> + internalVar (name (extern ++ suffix) (Just (myPkg, myMod))) comment + _ -> + error $ "Var is not local, global or external!" + where + comment = myMod ++ "." ++ extern ++ suffix + suffix = case msuffix of + Just s -> s + _ -> "" + vname = Var.varName v + hasMod = case nameModule_maybe vname of + Nothing -> False + _ -> True + myMod = + maybe thisMod (moduleNameString . moduleName) (nameModule_maybe vname) + myPkg = + maybe "main" (showOutputable . modulePackageId) (nameModule_maybe vname) + extern = occNameString $ nameOccName vname + unique = show $ nameUnique vname + +-- | Generate an argument list. Any arguments of type State# a are filtered out. +genArgs :: [StgArg] -> JSGen Config [AST Exp] +genArgs = mapM genArg . filter hasRep + where + hasRep (StgVarArg v) = hasRepresentation v + hasRep _ = True + +-- | Filter out args without representation, along with their accompanying +-- pair element, then generate code for the args. +-- Se `genArgVarsPair` for more information. +genArgsPair :: [(StgArg, a)] -> JSGen Config ([AST Exp], [a]) +genArgsPair aps = do + args' <- mapM genArg args + return (args', xs) + where + (args, xs) = unzip $ filter hasRep aps + hasRep (StgVarArg v, _) = hasRepresentation v + hasRep _ = True + +-- | Returns True if the given var actually has a representation. +-- Currently, only values of type State# a are considered representationless. +hasRepresentation :: Var.Var -> Bool +hasRepresentation = typeHasRep . varType + +typeHasRep :: Type -> Bool +typeHasRep t = + case splitTyConApp_maybe t of + Just (tc, _) -> tc /= statePrimTyCon + _ -> True + +genArg :: StgArg -> JSGen Config (AST Exp) +genArg (StgVarArg v) = varExp <$> genVar v +genArg (StgLitArg l) = genLit l + +-- | Generate code for data constructor creation. Returns a pair of +-- (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)) + where + strict MarkedStrict = True + strict _ = False + +-- | Generate the tag for a data constructor. This is used both by genDataCon +-- and directly by genCase to generate constructors for matching. +-- +-- IMPORTANT: remember to update the RTS if any changes are made to the +-- constructor tag values! +genDataConTag :: DataCon -> AST Exp +genDataConTag d = do + let n = occNameString $ nameOccName $ dataConName d + m = moduleNameString $ moduleName $ nameModule $ dataConName d + case (n, m) of + ("True", "GHC.Types") -> lit True + ("False", "GHC.Types") -> lit False + _ -> lit (fromIntegral $ dataConTag d :: Double) + +-- | Generate literals. +genLit :: L.Literal -> JSGen Config (AST Exp) +genLit l = do + case l of + MachStr s -> return . lit $ hexifyString s + MachInt n + | n > 2147483647 || + n < -2147483648 -> do warn Normal (constFail "Int" n) + return $ truncInt n + | otherwise -> return . litN $ fromIntegral n + MachFloat f -> return . litN $ fromRational f + MachDouble d -> return . litN $ fromRational d + MachChar c -> return . litN $ fromIntegral $ ord c + MachWord w + | w > 0xffffffff -> do warn Normal (constFail "Word" w) + return $ truncWord w + | otherwise -> return . litN $ fromIntegral w + MachWord64 w -> return . litN $ fromIntegral w + MachNullAddr -> return $ litN 0 + MachInt64 n -> return . litN $ fromIntegral n + LitInteger n _ -> return . lit $ n + MachLabel _ _ _ -> return $ lit ":(" -- Labels point to machine code - ignore! + where + constFail t n = t ++ " literal " ++ show n ++ " doesn't fit in 32 bits;" + ++ " truncating!" + truncInt n = litN . fromIntegral $ (fromIntegral n :: Int32) + truncWord w = litN . fromIntegral $ (fromIntegral w :: Word32) + +-- | Generate a function application. +genApp :: Var.Var -> [StgArg] -> JSGen Config (AST Exp) +genApp f xs = do + f' <- varExp <$> genVar f + xs' <- mapM genArg xs + if null xs + then return $ eval f' + else return $ call arity f' xs' + where + arity = arityInfo $ idInfo f + +-- | Returns True if the given Var is an unboxed tuple with a single element +-- after any represenationless elements are discarded. +isUnaryUnboxedTuple :: Var.Var -> Bool +isUnaryUnboxedTuple v = maybe False id $ do + (_, args) <- splitTyConApp_maybe t + case filter typeHasRep args of + [_] -> return $ isUnboxedTupleType t + _ -> return False + where + t = varType v + +-- | Is it safe to reorder values of the given type? +reorderableType :: Var.Var -> Bool +reorderableType v = + case splitTyConApp_maybe t of + Just (_, args) -> length (filter typeHasRep args) == length args + _ -> typeHasRep t + where + t = varType v + +-- | Generate a JS \xXX or \uXXXX escape sequence for a char if it's >127. +toHex :: Char -> String +toHex c = + case ord c of + n | n < 127 -> [c] + | otherwise -> toHex' (n `rem` 65536) + where + toHex' n = + case toH "" n of + s@(_:_:[]) -> "\\x" ++ s + s -> "\\u" ++ s + + toH s 0 = s + toH s n = case n `quotRem` 16 of + (next, ch) -> toH (i2h ch : s) next + + i2h n | n < 10 = chr (n + 48) + | otherwise = chr (n + 87) + +-- | Escape all non-ASCII characters in the given string. +hexifyString :: FastString -> String +hexifyString = concatMap toHex . unpackFS diff --git a/src/Haste/Config.hs b/src/Haste/Config.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Config.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haste.Config ( + Config (..), AppStart, defConfig, stdJSLibs, startASAP, + startOnLoadComplete, fastMultiply, safeMultiply) where +import Data.JSTarget +import System.IO.Unsafe (unsafePerformIO) +import System.FilePath (replaceExtension) +import Paths_haste_compiler (getDataFileName) +import DynFlags +import Data.ByteString.Lazy.Builder +import Data.Monoid +import Haste.Environment + +type AppStart = Builder -> Builder + +stdJSLibs :: [FilePath] +stdJSLibs = unsafePerformIO $ mapM getDataFileName [ + "rts.js", "stdlib.js", "MVar.js", "StableName.js", "Integer.js", "md5.js", + "array.js", "pointers.js" + ] + +-- | Execute the program as soon as it's loaded into memory. +-- Evaluate the result of applying main, as we might get a thunk back if +-- we're doing TCE. This is so cheap, small and non-intrusive we might +-- as well always do it this way, to simplify the config a bit. +startASAP :: AppStart +startASAP mainSym = + "A(" <> mainSym <> ", [0]);" + +-- | Execute the program when the document has finished loading. +startOnLoadComplete :: AppStart +startOnLoadComplete mainSym = + "window.onload = function() {" <> startASAP mainSym <> "};" + +-- | Int op wrapper for strictly 32 bit (|0). +strictly32Bits :: AST Exp -> AST Exp +strictly32Bits = flip (binOp BitOr) (litN 0) + +-- | Safe Int multiplication. +safeMultiply :: AST Exp -> AST Exp -> AST Exp +safeMultiply a b = callForeign "imul" [a, b] + +-- | Fast but unsafe Int multiplication. +fastMultiply :: AST Exp -> AST Exp -> AST Exp +fastMultiply = binOp Mul + +-- | Compiler configuration. +data Config = Config { + -- | Runtime files to dump into the JS blob. + rtsLibs :: [FilePath], + -- | Path to directory where system jsmods are located. + libPath :: FilePath, + -- | Write all jsmods to this path. + targetLibPath :: FilePath, + -- | A function that takes the main symbol as its input and outputs the + -- code that starts the program. + appStart :: AppStart, + -- | Options to the pretty printer. + ppOpts :: PPOpts, + -- | A function that takes the name of the a target as its input and + -- outputs the name of the file its JS blob should be written to. + outFile :: String -> String, + -- | Link the program? + performLink :: Bool, + -- | A function to call on each Int arithmetic primop. + wrapIntMath :: AST Exp -> AST Exp, + -- | Operation to use for Int multiplication. + multiplyIntOp :: AST Exp -> AST Exp -> AST Exp, + -- | Be verbose about warnings, etc.? + verbose :: Bool, + -- | Perform optimizations over the whole program at link time? + wholeProgramOpts :: Bool, + -- | Allow the possibility that some tail recursion may not be optimized + -- in order to gain slightly smaller code? + sloppyTCE :: Bool, + -- | Run the entire thing through Google Closure when done? + useGoogleClosure :: Maybe FilePath, + -- | Any external Javascript to link into the JS bundle. + jsExternals :: [FilePath], + -- | Dynamic flags used for compilation. + dynFlags :: DynFlags + } + +-- | Default compiler configuration. +defConfig :: Config +defConfig = Config { + rtsLibs = stdJSLibs, + libPath = jsmodDir, + targetLibPath = ".", + appStart = startOnLoadComplete, + ppOpts = def, + outFile = flip replaceExtension "js", + performLink = True, + wrapIntMath = strictly32Bits, + multiplyIntOp = safeMultiply, + verbose = False, + wholeProgramOpts = False, + sloppyTCE = False, + useGoogleClosure = Nothing, + jsExternals = [], + dynFlags = tracingDynFlags + } diff --git a/src/Haste/Environment.hs b/src/Haste/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Environment.hs @@ -0,0 +1,76 @@ +-- | Paths, host bitness and other environmental information about Haste. +module Haste.Environment where +import System.Process +import System.IO.Unsafe +import System.Directory +import System.FilePath +import Data.Bits (bitSize) +import Foreign.C.Types (CIntPtr) + +-- | Host word size in bits. +hostWordSize :: Int +hostWordSize = bitSize (undefined :: CIntPtr) + +-- | Directory where cabal resides. Bundled JS files end up here. +cabalDir :: FilePath +cabalDir = unsafePerformIO $ getAppUserDataDirectory "cabal" + +-- | Cabal dir for binaries. +cabalBinDir :: FilePath +cabalBinDir = cabalDir "bin" + +-- | Directory housing hi files, jsmods and other stuff Haste spits out. +hasteDir :: FilePath +hasteDir = unsafePerformIO $ getAppUserDataDirectory "haste" + +jsmodDir :: FilePath +jsmodDir = hasteDir "lib" + +-- | Directory containing library information. +pkgLibDir :: FilePath +pkgLibDir = hasteInstDir "lib" + +-- | Base directory for haste-inst. +hasteInstDir :: FilePath +hasteInstDir = hasteDir "haste-install" + +-- | Directory housing package information. +pkgDir :: FilePath +pkgDir = hasteDir "haste-pkg" + +-- | Run a process and wait for its completion. +runAndWait :: FilePath -> [String] -> Maybe FilePath -> IO () +runAndWait file args workDir = do + h <- runProcess file args workDir Nothing Nothing Nothing Nothing + _ <- waitForProcess h + return () + +-- | Find an executable. +locateBinary :: String -> [FilePath] -> IO (Either String FilePath) +locateBinary progname (c:cs) = do + mexe <- findExecutable c + case mexe of + Nothing -> locateBinary progname cs + Just exe -> return (Right exe) +locateBinary progname _ = do + return $ Left $ "No " ++ progname ++ " executable found; aborting!" + +-- | Find a binary that's probably in Cabal's bin directory. +binaryPath :: FilePath -> FilePath +binaryPath exe = unsafePerformIO $ do + b <- locateBinary exe [exe, cabalBinDir exe] + case b of + Left err -> error err + Right path -> return path + +-- | The main Haste compiler binary. +hasteBinary :: FilePath +hasteBinary = binaryPath "hastec" + +-- | Binary for haste-pkg. +hastePkgBinary :: FilePath +hastePkgBinary = binaryPath "haste-pkg" + +-- | JAR for Closure compiler. +closureCompiler :: FilePath +closureCompiler = hasteDir "compiler.jar" diff --git a/src/Haste/Errors.hs b/src/Haste/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Errors.hs @@ -0,0 +1,22 @@ +-- | Functions for warning about and causing runtime errors. +module Haste.Errors (runtimeError, warn, WarnLevel(..)) where +import System.IO.Unsafe +import System.IO +import Data.JSTarget +import Haste.Monad +import Haste.Config + +data WarnLevel = Normal | Verbose deriving Eq + +-- | Produce a runtime error whenever this expression gets evaluated. +runtimeError :: String -> AST Exp +runtimeError s = callForeign "die" [lit s] + +-- | Produce a warning message. This function is horrible and should be +-- replaced with some proper handling for warnings. +warn :: WarnLevel -> String -> JSGen Config () +warn wlvl msg = do + vrb <- verbose `fmap` getCfg + if wlvl == Normal || vrb + then return $! unsafePerformIO $ hPutStrLn stderr $ "WARNING: " ++ msg + else return () diff --git a/src/Haste/Linker.hs b/src/Haste/Linker.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Linker.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module Haste.Linker (link) where +import Haste.Config +import Haste.Module +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Monad.State.Strict +import Control.Applicative +import Data.JSTarget +import qualified Data.ByteString.Lazy as B +import Data.ByteString.Lazy.Builder +import Data.Monoid + +-- | The program entry point. +-- This will need to change when we start supporting building "binaries" +-- using cabal, since we'll have all sorts of funny package names then. +mainSym :: Name +mainSym = name "main" (Just ("main", "Main")) + +-- | Link a program using the given config and input file name. +link :: Config -> String -> FilePath -> IO () +link cfg pkgid target = do + ds <- getAllDefs (libPath cfg) pkgid mainSym + let myDefs = if wholeProgramOpts cfg then topLevelInline ds else ds + let (progText, mainSym') = prettyProg (ppOpts cfg) mainSym myDefs + callMain = appStart cfg mainSym' + + rtslibs <- mapM readFile $ rtsLibs cfg ++ jsExternals cfg + B.writeFile (outFile cfg target) + $ toLazyByteString + $ stringUtf8 (unlines rtslibs) + <> progText + <> callMain + +-- | Generate a sequence of all assignments needed to run Main.main. +getAllDefs :: FilePath -> String -> Name -> IO (AST Stm) +getAllDefs libpath pkgid mainsym = + runDep $ addDef libpath pkgid mainsym + +data DepState = DepState { + defs :: !(AST Stm -> AST Stm), + alreadySeen :: !(S.Set Name), + modules :: !(M.Map String Module) + } + +newtype DepM a = DepM (StateT DepState IO a) + deriving (Monad, MonadIO) + +initState :: DepState +initState = DepState { + defs = id, + alreadySeen = S.empty, + modules = M.empty + } + +-- | Run a dependency resolution computation. +runDep :: DepM a -> IO (AST Stm) +runDep (DepM m) = do + defs' <- defs . snd <$> runStateT m initState + return (defs' nullRet) + +instance MonadState DepState DepM where + get = DepM $ get + put = DepM . put + +-- | Return the module the given variable resides in. +getModuleOf :: FilePath -> Name -> DepM Module +getModuleOf libpath v = + case moduleOf v of + Just "GHC.Prim" -> return foreignModule + Just "" -> return foreignModule + Just m -> getModule libpath (maybe "main" id $ pkgOf v) m + _ -> return foreignModule + +-- | Return the module at the given path, loading it into cache if it's not +-- already there. +getModule :: FilePath -> String -> String -> DepM Module +getModule libpath pkgid modname = do + st <- get + case M.lookup modname (modules st) of + Just m -> + return m + _ -> do + liftIO $ putStrLn $ "Linking " ++ modname + m <- liftIO $ readModule libpath pkgid modname + put st {modules = M.insert modname m (modules st)} + return m + +-- | Add a new definition and its dependencies. If the given identifier has +-- already been added, it's just ignored. +addDef :: FilePath -> String -> Name -> DepM () +addDef libpath pkgid v = do + st <- get + when (not $ v `S.member` alreadySeen st) $ do + m <- getModuleOf libpath v + + -- getModuleOf may update the state, so we need to refresh it + st' <- get + let dependencies = maybe S.empty id (M.lookup v (modDeps m)) + put st' {alreadySeen = S.insert v (alreadySeen st')} + S.foldl' (\a x -> a >> addDef libpath pkgid x) (return ()) dependencies + + -- addDef _definitely_ updates the state, so refresh once again + st'' <- get + let Name comment _ = v + defs' = + maybe (defs st'') + (\body -> defs st'' . newVar True (internalVar v comment) body) + (M.lookup v (modDefs m)) + put st'' {defs = defs'} diff --git a/src/Haste/Module.hs b/src/Haste/Module.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Module.hs @@ -0,0 +1,54 @@ +-- | Read and write JSMods. +module Haste.Module (writeModule, readModule, readModuleFingerprint) where +import Module (moduleNameSlashes, mkModuleName) +import qualified Data.ByteString.Lazy as B +import System.FilePath +import System.Directory +import System.IO +import Control.Applicative +import Data.JSTarget +import Data.Binary + +-- | The file extension to use for modules. +jsmodExt :: String +jsmodExt = "jsmod" + +moduleFilePath :: FilePath -> String -> String -> FilePath +moduleFilePath basepath pkgid modname = + flip addExtension jsmodExt $ + basepath pkgid (moduleNameSlashes $ mkModuleName modname) + +readModuleFingerprint :: FilePath -> String -> String -> IO Fingerprint +readModuleFingerprint basepath pkgid modname = do + x <- doesFileExist path + let path' = if x then path else syspath + withFile path' ReadMode $ \h -> do + fp <- decode <$> B.hGetContents h + return $! fp + where + path = moduleFilePath "" "" modname + syspath = moduleFilePath basepath pkgid modname + +-- | Write a module to file, with the extension specified in `fileExt`. +-- Assuming that fileExt = "jsmod", a module Foo.Bar is written to +-- basepath/Foo/Bar.jsmod +-- If any directory in the path where the module is to be written doesn't +-- exist, it gets created. +writeModule :: FilePath -> Module -> IO () +writeModule basepath m@(Module _ pkgid modname _ _) = do + createDirectoryIfMissing True (takeDirectory path) + B.writeFile path (encode m) + where + path = moduleFilePath basepath pkgid modname + +-- | Read a module from file. If the module is not found at the specified path, +-- libpath/path is tried instead. Panics if the module is found on neither +-- path. +readModule :: FilePath -> String -> String -> IO Module +readModule basepath pkgid modname = do + x <- doesFileExist path + let path' = if x then path else syspath + decode <$> B.readFile path' + where + path = moduleFilePath "." pkgid modname + syspath = moduleFilePath basepath pkgid modname diff --git a/src/Haste/Monad.hs b/src/Haste/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Monad.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-} +module Haste.Monad ( + JSGen, genJS, dependOn, getModName, addLocal, getCfg, continue, isolate, + pushBind, popBind, getCurrentBinding + ) where +import Control.Monad.State +import Data.JSTarget as J hiding (modName) +import qualified Data.Set as S +import Control.Applicative + +data GenState cfg = GenState { + deps :: !(S.Set Name), + locals :: !(S.Set Name), + continuation :: !(AST Stm -> AST Stm), + bindStack :: [Var], + modName :: String, + config :: cfg + } + +initialState :: GenState cfg +initialState = GenState { + deps = S.empty, + locals = S.empty, + continuation = id, + bindStack = [], + modName = undefined, + config = undefined + } + +newtype JSGen cfg a = + JSGen (State (GenState cfg) a) + deriving (Monad, Functor, Applicative) + +class Dependency a where + -- | Add a dependency to the function currently being generated. + dependOn :: a -> JSGen cfg () + -- | Mark a symbol as local, excluding it from the dependency graph. + addLocal :: a -> JSGen cfg () + +instance Dependency J.Name where + dependOn v = JSGen $ do + st <- get + put st {deps = S.insert v (deps st)} + + addLocal v = JSGen $ do + st <- get + put st {locals = S.insert v (locals st)} + +instance Dependency J.Var where + dependOn (Foreign _) = return () + dependOn (Internal n _) = dependOn n + addLocal (Foreign _) = return () + addLocal (Internal n _) = addLocal n + +instance Dependency a => Dependency [a] where + dependOn = mapM_ dependOn + addLocal = mapM_ addLocal + +instance Dependency a => Dependency (S.Set a) where + dependOn = dependOn . S.toList + addLocal = addLocal . S.toList + +genJS :: cfg -- ^ Config to use for code generation. + -> String -- ^ Name of the module being compiled. + -> JSGen cfg a -- ^ The code generation computation. + -> (a, S.Set J.Name, S.Set J.Name, AST Stm -> AST Stm) +genJS cfg myModName (JSGen gen) = + case runState gen initialState {modName = myModName, config = cfg} of + (a, GenState dependencies loc cont _ _ _) -> + (a, dependencies, loc, cont) + +getModName :: JSGen cfg String +getModName = JSGen $ modName <$> get + +pushBind :: Var -> JSGen cfg () +pushBind v = JSGen $ do + st <- get + put st {bindStack = v : bindStack st} + +popBind :: JSGen cfg () +popBind = JSGen $ do + st <- get + put st {bindStack = tail $ bindStack st} + +getCurrentBinding :: JSGen cfg Var +getCurrentBinding = JSGen $ fmap (head . bindStack) get + +-- | Add a new continuation onto the current one. +continue :: (AST Stm -> AST Stm) -> JSGen cfg () +continue cont = JSGen $ do + st <- get + put st {continuation = continuation st . cont} + +-- | Run a GenJS computation in isolation, returning its results rather than +-- writing them to the output stream. Dependencies and locals are still +-- updated, however. +isolate :: JSGen cfg a -> JSGen cfg (a, AST Stm -> AST Stm) +isolate gen = do + myMod <- getModName + cfg <- getCfg + b <- getCurrentBinding + let (x, dep, loc, cont) = genJS cfg myMod (pushBind b >> gen) + dependOn dep + addLocal loc + return (x, cont) + +getCfg :: JSGen cfg cfg +getCfg = JSGen $ fmap config get diff --git a/src/Haste/PrimOps.hs b/src/Haste/PrimOps.hs new file mode 100644 --- /dev/null +++ b/src/Haste/PrimOps.hs @@ -0,0 +1,320 @@ +module Haste.PrimOps (genOp) where +import Prelude hiding (LT, GT) +import PrimOp +import Data.JSTarget +import Haste.Config +import Haste.Util + +-- | Dummy State# RealWorld value for where one is needed. +defState :: AST Exp +defState = litN 0 + +-- | Generate primops. +-- Many of these ops return lifted Bool values; however, no thunk is +-- generated for them in order to conserve space and CPU time. This relies +-- on the evaluation operation in the RTS being able to handle plain values +-- as though they were thunks. If this were to change, all those ops MUST +-- be changed to return thunks! +genOp :: Config -> PrimOp -> [AST Exp] -> Either String (AST Exp) +genOp cfg op xs = + case op of + -- negations + IntNegOp -> Right $ binOp Sub (litN 0) (head xs) + DoubleNegOp -> Right $ binOp Sub (litN 0) (head xs) + FloatNegOp -> Right $ binOp Sub (litN 0) (head xs) + NotOp -> Right $ not_ (head xs) -- bitwise + + -- Conversions + ChrOp -> Right $ head xs + OrdOp -> Right $ head xs + Word2IntOp -> Right $ binOp BitAnd (head xs) (litN 0xffffffff) + Int2WordOp -> Right $ binOp ShrL (head xs) (litN 0) + Int2FloatOp -> Right $ head xs + Int2DoubleOp -> Right $ head xs + Double2IntOp -> Right $ binOp (BitAnd) (head xs) (litN 0xffffffff) + Double2FloatOp -> Right $ head xs + Float2IntOp -> Right $ binOp (BitAnd) (head xs) (litN 0xffffffff) + Float2DoubleOp -> Right $ head xs + + -- Narrowing ops + Narrow8IntOp -> Right $ binOp BitAnd (head xs) (lit (0xff :: Double)) + Narrow16IntOp -> Right $ binOp BitAnd (head xs) (lit (0xffff :: Double)) + Narrow32IntOp -> Right $ binOp BitAnd (head xs) (lit (0xffffffff :: Double)) + Narrow8WordOp -> Right $ binOp BitAnd (head xs) (lit (0xff :: Double)) + Narrow16WordOp -> Right $ binOp BitAnd (head xs) (lit (0xffff :: Double)) + Narrow32WordOp -> Right $ binOp ShrL (binOp BitAnd (head xs) (lit (0xffffffff :: Double))) (litN 0) + + -- Char ops + CharGtOp -> bOp GT + CharGeOp -> bOp GTE + CharEqOp -> bOp Eq + CharNeOp -> bOp Neq + CharLtOp -> bOp LT + CharLeOp -> bOp LTE + + -- Int ops + IntAddOp -> intMath $ bOp Add + IntSubOp -> intMath $ bOp Sub + IntMulOp -> intMath $ Right $ multiplyIntOp cfg (xs !! 0) (xs !! 1) + -- FIXME: this is correct but slow! + IntMulMayOfloOp -> intMath $ Right $ multiplyIntOp cfg (xs !! 0) (xs !! 1) + IntQuotOp -> callF "quot" + IntQuotRemOp -> callF "quotRemI" + IntRemOp -> bOp Mod -- JS % operator is actually rem, not mod! + IntAddCOp -> callF "addC" + IntSubCOp -> callF "subC" + ISllOp -> bOp Shl + ISraOp -> bOp ShrA + ISrlOp -> bOp ShrL + IntGtOp -> bOp GT + IntGeOp -> bOp GTE + IntLtOp -> bOp LT + IntLeOp -> bOp LTE + IntEqOp -> bOp Eq + IntNeOp -> bOp Neq + + -- Word ops + WordAddOp -> wordMath $ bOp Add + WordSubOp -> wordMath $ bOp Sub + WordMulOp -> wordMath $ callF "imul" + WordQuotOp -> callF "quot" + WordQuotRemOp -> callF "quotRemI" + WordRemOp -> bOp Mod + AndOp -> wordMath $ bOp BitAnd + OrOp -> wordMath $ bOp BitOr + XorOp -> wordMath $ bOp BitXor + SllOp -> wordMath $ bOp Shl + SrlOp -> bOp ShrL + WordGtOp -> bOp GT + WordGeOp -> bOp GTE + WordEqOp -> bOp Eq + WordNeOp -> bOp Neq + WordLtOp -> bOp LT + WordLeOp -> bOp LTE + + -- Double ops + DoubleExpOp -> Right $ callForeign "Math.exp" xs + DoubleLogOp -> Right $ callForeign "Math.log" xs + DoubleSqrtOp -> Right $ callForeign "Math.sqrt" xs + DoubleCosOp -> Right $ callForeign "Math.cos" xs + DoubleSinOp -> Right $ callForeign "Math.sin" xs + DoubleTanOp -> Right $ callForeign "Math.tan" xs + DoubleAcosOp -> Right $ callForeign "Math.acos" xs + DoubleAsinOp -> Right $ callForeign "Math.asin" xs + DoubleAtanOp -> Right $ callForeign "Math.atan" xs + DoubleCoshOp -> Right $ callForeign "cosh" xs + DoubleSinhOp -> Right $ callForeign "sinh" xs + DoubleTanhOp -> Right $ callForeign "tanh" xs + DoubleDecode_2IntOp -> Right $ callForeign "decodeDouble" xs + DoubleGtOp -> bOp GT + DoubleGeOp -> bOp GTE + DoubleEqOp -> bOp Eq + DoubleNeOp -> bOp Neq + DoubleLtOp -> bOp LT + DoubleLeOp -> bOp LTE + DoubleAddOp -> bOp Add + DoubleSubOp -> bOp Sub + DoubleMulOp -> bOp Mul + DoubleDivOp -> bOp Div + DoublePowerOp -> callF "Math.pow" + + -- Float ops + FloatExpOp -> Right $ callForeign "Math.exp" xs + FloatLogOp -> Right $ callForeign "Math.log" xs + FloatSqrtOp -> Right $ callForeign "Math.sqrt" xs + FloatCosOp -> Right $ callForeign "Math.cos" xs + FloatSinOp -> Right $ callForeign "Math.sin" xs + FloatTanOp -> Right $ callForeign "Math.tan" xs + FloatAcosOp -> Right $ callForeign "Math.acos" xs + FloatAsinOp -> Right $ callForeign "Math.asin" xs + FloatAtanOp -> Right $ callForeign "Math.atan" xs + FloatCoshOp -> Right $ callForeign "cosh" xs + FloatSinhOp -> Right $ callForeign "sinh" xs + FloatTanhOp -> Right $ callForeign "tanh" xs + FloatDecode_IntOp -> Right $ callForeign "decodeFloat" xs + FloatGtOp -> bOp GT + FloatGeOp -> bOp GTE + FloatEqOp -> bOp Eq + FloatNeOp -> bOp Neq + FloatLtOp -> bOp LT + FloatLeOp -> bOp LTE + FloatAddOp -> bOp Add + FloatSubOp -> bOp Sub + FloatMulOp -> bOp Mul + FloatDivOp -> bOp Div + FloatPowerOp -> callF "Math.pow" + + -- Array ops + NewArrayOp -> callF "newArr" + SameMutableArrayOp -> fmap (thunk . ret) $ bOp Eq + ReadArrayOp -> Right $ index arr ix + WriteArrayOp -> Right $ assignEx (index arr ix) rhs + where (_arr:_ix:rhs:_) = xs + SizeofArrayOp -> Right $ index (head xs) (lit "length") + SizeofMutableArrayOp -> Right $ index (head xs) (lit "length") + IndexArrayOp -> Right $ index arr ix + UnsafeFreezeArrayOp -> Right $ head xs + UnsafeThawArrayOp -> Right $ head xs + -- TODO: copy, clone, freeze, thaw + + -- Byte Array ops + NewByteArrayOp_Char -> callF "newByteArr" + NewPinnedByteArrayOp_Char-> callF "newByteArr" + SameMutableByteArrayOp -> fmap (thunk . ret) $ bOp Eq + IndexByteArrayOp_Char -> readArr xs "i8" + IndexByteArrayOp_Int -> readArr xs "i32" + IndexByteArrayOp_Int8 -> readArr xs "i8" + IndexByteArrayOp_Int16 -> readArr xs "i16" + IndexByteArrayOp_Int32 -> readArr xs "i32" + IndexByteArrayOp_Word -> readArr xs "w32" + IndexByteArrayOp_Word8 -> readArr xs "w8" + IndexByteArrayOp_Word16 -> readArr xs "w16" + IndexByteArrayOp_Word32 -> readArr xs "w32" + IndexByteArrayOp_WideChar-> readArr xs "w32" + IndexByteArrayOp_Float -> readArr xs "f32" + IndexByteArrayOp_Double -> readArr xs "f64" + + ReadByteArrayOp_Char -> readArr xs "i8" + ReadByteArrayOp_Int -> readArr xs "i32" + ReadByteArrayOp_Int8 -> readArr xs "i8" + ReadByteArrayOp_Int16 -> readArr xs "i16" + ReadByteArrayOp_Int32 -> readArr xs "i32" + ReadByteArrayOp_Word -> readArr xs "w32" + ReadByteArrayOp_Word8 -> readArr xs "w8" + ReadByteArrayOp_Word16 -> readArr xs "w16" + ReadByteArrayOp_Word32 -> readArr xs "w32" + ReadByteArrayOp_WideChar -> readArr xs "w32" + ReadByteArrayOp_Float -> readArr xs "f32" + ReadByteArrayOp_Double -> readArr xs "f64" + + WriteByteArrayOp_Char -> writeArr xs "i8" + WriteByteArrayOp_Int -> writeArr xs "i32" + WriteByteArrayOp_Int8 -> writeArr xs "i8" + WriteByteArrayOp_Int16 -> writeArr xs "i16" + WriteByteArrayOp_Int32 -> writeArr xs "i32" + WriteByteArrayOp_Word -> writeArr xs "w32" + WriteByteArrayOp_Word8 -> writeArr xs "w8" + WriteByteArrayOp_Word16 -> writeArr xs "w16" + WriteByteArrayOp_Word32 -> writeArr xs "w32" + WriteByteArrayOp_WideChar-> writeArr xs "w32" + WriteByteArrayOp_Float -> writeArr xs "f32" + WriteByteArrayOp_Double -> writeArr xs "f64" + + SizeofByteArrayOp -> Right $ index (head xs) (lit "byteLength") + SizeofMutableByteArrayOp -> Right $ index (head xs) (lit "byteLength") + NewAlignedPinnedByteArrayOp_Char -> Right $ callForeign "newByteArr" [xs!!0] + UnsafeFreezeByteArrayOp -> Right $ head xs + ByteArrayContents_Char -> Right $ head xs + + -- Mutable variables + NewMutVarOp -> callF "nMV" + ReadMutVarOp -> callF "rMV" + WriteMutVarOp -> callF "wMV" + + -- Pointer ops + WriteOffAddrOp_Char -> writeOffAddr xs "i8" 1 + WriteOffAddrOp_Int -> writeOffAddr xs "i32" 4 + WriteOffAddrOp_Int8 -> writeOffAddr xs "i8" 1 + WriteOffAddrOp_Int16 -> writeOffAddr xs "i16" 2 + WriteOffAddrOp_Int32 -> writeOffAddr xs "i32" 4 + WriteOffAddrOp_Word -> writeOffAddr xs "w32" 4 + WriteOffAddrOp_Word8 -> writeOffAddr xs "w8" 1 + WriteOffAddrOp_Word16 -> writeOffAddr xs "w16" 2 + WriteOffAddrOp_Word32 -> writeOffAddr xs "w32" 4 + WriteOffAddrOp_WideChar-> writeOffAddr xs "w32" 4 + WriteOffAddrOp_Float -> writeOffAddr xs "f32" 4 + WriteOffAddrOp_Double -> writeOffAddr xs "f64" 8 + ReadOffAddrOp_Char -> readOffAddr xs "i8" 1 + ReadOffAddrOp_Int -> readOffAddr xs "i32" 4 + ReadOffAddrOp_Int8 -> readOffAddr xs "i8" 1 + ReadOffAddrOp_Int16 -> readOffAddr xs "i16" 2 + ReadOffAddrOp_Int32 -> readOffAddr xs "i32" 4 + ReadOffAddrOp_Word -> readOffAddr xs "w32" 4 + ReadOffAddrOp_Word8 -> readOffAddr xs "w8" 1 + ReadOffAddrOp_Word16 -> readOffAddr xs "w16" 2 + ReadOffAddrOp_Word32 -> readOffAddr xs "w32" 4 + ReadOffAddrOp_WideChar -> readOffAddr xs "w32" 4 + ReadOffAddrOp_Float -> readOffAddr xs "f32" 4 + ReadOffAddrOp_Double -> readOffAddr xs "f64" 8 + AddrAddOp -> callF "plusAddr" + AddrSubOp -> + Right $ callForeign "plusAddr" [addr, binOp Sub (litN 0) off] + where (addr:off:_) = xs + AddrEqOp -> callF "addrEq" + AddrNeOp -> + Right $ binOp Sub (litN 0) $ callForeign "addrEq" [a, b] + where (a:b:_) = xs + AddrLtOp -> callF "addrLT" + AddrGtOp -> callF "addrGT" + AddrLeOp -> + Right $ binOp Sub (litN 0) $ callForeign "addrGT" [a, b] + where (a:b:_) = xs + AddrGeOp -> + Right $ binOp Sub (litN 0) $ callForeign "addrLT" [a, b] + where (a:b:_) = xs + + -- MVars + NewMVarOp -> callF "newMVar" + TakeMVarOp -> callF "takeMVar" + TryTakeMVarOp -> callF "tryTakeMVar" + PutMVarOp -> callF "putMVar" + TryPutMVarOp -> callF "tryPutMVar" + SameMVarOp -> callF "sameMVar" + IsEmptyMVarOp -> callF "isEmptyMVar" + + -- Stable names + MakeStableNameOp -> callF "makeStableName" + EqStableNameOp -> callF "eqStableName" + StableNameToIntOp -> Right $ head xs + + -- Exception masking + -- There's only one thread anyway, so async exceptions can't happen. + MaskAsyncExceptionsOp -> Right $ callSaturated (head xs) [] + UnmaskAsyncExceptionsOp -> Right $ callSaturated (head xs) [] + MaskStatus -> Right $ litN 0 + + -- Misc. ops + SeqOp -> Right $ callForeign "E" [head xs] + AtomicallyOp -> Right $ callSaturated (xs !! 0) [] + -- Get the data constructor tag from a value. + DataToTagOp -> callF "dataToTag" + TouchOp -> Right $ defState + RaiseOp -> callF "die" + RaiseIOOp -> callF "die" + -- noDuplicate is only relevant in a threaded environment. + NoDuplicateOp -> Right $ defState + CatchOp -> callF "jsCatch" + x -> Left $ "Unsupported PrimOp: " ++ showOutputable x + where + (arr:ix:_) = xs + + writeArr (a:i:rhs:_) elemtype = + Right $ assignEx (index (index (index a (lit "v")) (lit elemtype)) i) rhs + writeArr _ _ = + error "writeArray primop with too few arguments!" + + readArr (a:i:_) elemtype = + Right $ index (index (index a (lit "v")) (lit elemtype)) i + readArr _ _ = + error "writeArray primop with too few arguments!" + + writeOffAddr (addr:off:rhs:_) etype esize = + Right $ callForeign "writeOffAddr" [lit etype, litN esize, addr, off, rhs] + writeOffAddr _ _ _ = + error "writeOffAddr primop with too few arguments!" + + readOffAddr (addr:off:_) etype esize = + Right $ callForeign "readOffAddr" [lit etype, litN esize, addr, off] + readOffAddr _ _ _ = + error "readOffAddr primop with too few arguments!" + + callF f = Right $ callForeign f xs + + bOp bop = + case xs of + [x, y] -> Right $ binOp bop x y + _ -> error $ "PrimOps.binOp failed! op is " ++ show bop + + -- Bitwise ops on words need to be unsigned; exploit the fact that >>> is! + wordMath = fmap (\oper -> binOp ShrL oper (litN 0)) + intMath = fmap (wrapIntMath cfg) diff --git a/src/Haste/Util.hs b/src/Haste/Util.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Util.hs @@ -0,0 +1,8 @@ +-- | Misc. utility functions. +module Haste.Util where +import DynFlags +import Outputable + +showOutputable :: Outputable a => a -> String +showOutputable = showPpr tracingDynFlags + diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Version.hs @@ -0,0 +1,42 @@ +-- | Contains version information for Haste. +module Haste.Version (hasteVersion, ghcVersion, bootVersion, needsReboot, + BootVer (..), bootFile) where +import System.IO.Unsafe +import System.Directory +import System.FilePath (()) +import System.IO +import Data.Version +import Config (cProjectVersion) +import Haste.Environment (hasteDir) + +hasteVersion :: Version +hasteVersion = Version [0, 2] [] + +ghcVersion :: String +ghcVersion = cProjectVersion + +bootVersion :: BootVer +bootVersion = BootVer hasteVersion ghcVersion + +bootFile :: FilePath +bootFile = hasteDir "booted" + +data BootVer = BootVer Version String deriving (Read, Show) + +-- | Returns which parts of Haste need rebooting. A change in the boot file +-- format triggers a full reboot. +needsReboot :: Bool +needsReboot = unsafePerformIO $ do + exists <- doesFileExist bootFile + if exists + then do + fh <- openFile bootFile ReadMode + bootedVerString <- hGetLine fh + hClose fh + case reads bootedVerString of + [(BootVer hasteVer ghcVer, _)] -> + return $ hasteVer /= hasteVersion || ghcVer /= ghcVersion + _ -> + return True + else + return True diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,241 @@ +module Main (main) where +import GHC +import GHC.Paths (libdir) +import HscMain +import Outputable (showPpr) +import DynFlags hiding (flags) +import TidyPgm +import CorePrep +import CoreToStg +import StgSyn (StgBinding) +import HscTypes +import Module (moduleNameSlashes) +import GhcMonad +import System.Environment (getArgs) +import Control.Monad (when) +import Haste +import Haste.Util (showOutputable) +import Haste.Environment +import Haste.Version +import Args +import ArgSpecs +import System.FilePath (addExtension) +import System.IO +import System.Process (runProcess, waitForProcess, rawSystem) +import System.Exit (ExitCode (..), exitFailure) +import System.Directory (renameFile) +import Filesystem (getModified, isFile) +import Data.Version +import Data.List +import Data.String +import qualified Data.ByteString.Char8 as B + +logStr :: String -> IO () +logStr = hPutStrLn stderr + +rebootMsg :: String +rebootMsg = "Haste needs to be rebooted; please run haste-boot" + +printInfo :: IO () +printInfo = do + ghc <- runGhc (Just libdir) getSessionDynFlags + putStrLn $ formatInfo $ compilerInfo ghc + where + formatInfo = ('[' :) . tail . unlines . (++ ["]"]) . map ((',' :) . show) + +-- | Check for arguments concerning version info and the like, and act on them. +-- Return True if the compiler should run afterwards. +preArgs :: [String] -> IO Bool +preArgs args + | "--numeric-version" `elem` args = + putStrLn ghcVersion >> return False + | "--info" `elem` args = + printInfo >> return False + | "--version" `elem` args = + putStrLn (showVersion hasteVersion) >> return False + | "--supported-extensions" `elem` args = + (putStrLn $ unlines $ supportedLanguagesAndExtensions) >> return False + | "--supported-languages" `elem` args = + (putStrLn $ unlines $ supportedLanguagesAndExtensions) >> return False + | otherwise = + return True + +main :: IO () +main = do + args <- fmap (++ packageDBArgs) getArgs + runCompiler <- preArgs args + when (runCompiler) $ do + if allSupported args + then hasteMain args + else callVanillaGHC args + where + packageDBArgs = ["-no-global-package-db", + "-no-user-package-db", + "-package-db " ++ pkgDir] + +-- | Call vanilla GHC; used for boot files and the like. +callVanillaGHC :: [String] -> IO () +callVanillaGHC args = do + _ <- rawSystem "ghc" (filter noHasteArgs args) + return () + where + noHasteArgs x = + x /= "--libinstall" && + x /= "--unbooted" + +-- | Run the compiler if everything's satisfactorily booted, otherwise whine +-- and exit. +hasteMain :: [String] -> IO () +hasteMain args + | not needsReboot = + compiler ("-O2" : args) + | otherwise = do + if "--unbooted" `elem` args + then compiler (filter (/= "--unbooted") ("-O2" : args)) + else fail rebootMsg + +-- | Determine whether all given args are handled by Haste, or if we need to +-- ship them off to vanilla GHC instead. +allSupported :: [String] -> Bool +allSupported args = + and args' + where + args' = [not $ any (`isSuffixOf` a) someoneElsesProblems | a <- args] + someoneElsesProblems = [".c", ".cmm", ".hs-boot", ".lhs-boot"] + +-- | The main compiler driver. +compiler :: [String] -> IO () +compiler cmdargs = do + let cmdargs' | "--opt-all" `elem` cmdargs = "-O2" : cmdargs + | "--opt-all-unsafe" `elem` cmdargs = "-O2" : cmdargs + | otherwise = cmdargs + argRes = handleArgs defConfig argSpecs cmdargs' + usedGhcMode = if "-c" `elem` cmdargs then OneShot else CompManager + + case argRes of + -- We got --help as an argument - display help and exit. + Left help -> putStrLn help + + -- We got a config and a set of arguments for GHC; let's compile! + Right (cfg, ghcargs) -> do + -- Parse static flags, but ignore profiling. + (ghcargs', _) <- parseStaticFlags [noLoc a | a <- ghcargs, a /= "-prof"] + + runGhc (Just libdir) $ handleSourceError (const $ liftIO exitFailure) $ do + -- Handle dynamic GHC flags. Make sure __HASTE__ is #defined. + let args = "-D__HASTE__" : map unLoc ghcargs' + dynflags <- getSessionDynFlags + (dynflags', files, _) <- parseDynamicFlags dynflags (map noLoc args) + _ <- setSessionDynFlags dynflags' {ghcLink = NoLink, + ghcMode = usedGhcMode} + + -- Prepare and compile all needed targets. + let files' = map unLoc files + printErrorAndDie e = printException e >> liftIO exitFailure + deps <- handleSourceError printErrorAndDie $ do + ts <- mapM (flip guessTarget Nothing) files' + setTargets ts + _ <- load LoadAllTargets + depanal [] False + mapM_ (compile cfg dynflags') deps + + -- Link everything together into a .js file. + when (performLink cfg) $ liftIO $ do + flip mapM_ files' $ \file -> do + logStr $ "Linking " ++ outFile cfg file + let pkgid = showPpr dynflags $ thisPackage dynflags' + link cfg pkgid file + case useGoogleClosure cfg of + Just clopath -> closurize clopath $ outFile cfg file + _ -> return () + +-- | Do everything required to get a list of STG bindings out of a module. +prepare :: (GhcMonad m) => DynFlags -> ModSummary -> m ([StgBinding], ModuleName) +prepare dynflags theMod = do + env <- getSession + let name = moduleName $ ms_mod theMod + pgm <- parseModule theMod + >>= typecheckModule + >>= desugarModule + >>= liftIO . hscSimplify env . coreModule + >>= liftIO . tidyProgram env + >>= prepPgm env . fst + >>= liftIO . coreToStg dynflags + return (pgm, name) + where + prepPgm env tidy = liftIO $ do + prepd <- corePrepPgm dynflags env (cg_binds tidy) (cg_tycons tidy) + return prepd + + +-- | Run Google Closure on a file. +closurize :: FilePath -> FilePath -> IO () +closurize cloPath file = do + logStr $ "Running the Google Closure compiler on " ++ file ++ "..." + let cloFile = file `addExtension` ".clo" + cloOut <- openFile cloFile WriteMode + build <- runProcess "java" + ["-jar", cloPath, "--compilation_level", "ADVANCED_OPTIMIZATIONS", + "--jscomp_off", "uselessCode", "--jscomp_off", "globalThis", + file] + Nothing + Nothing + Nothing + (Just cloOut) + Nothing + res <- waitForProcess build + hClose cloOut + case res of + ExitFailure n -> + fail $ "Couldn't execute Google Closure compiler: " ++ show n + ExitSuccess -> + renameFile cloFile file + +-- | Generate a unique fingerprint for the compiler, command line arguments, +-- etc. +genFingerprint :: String -> FilePath -> [String] -> Fingerprint +genFingerprint modname targetpath args = + {- md5sum $ B.pack $ -} show [ + modname, + targetpath, + show bootVersion, + show args + ] + +-- | Compile a module into a .jsmod intermediate file. +compile :: (GhcMonad m) => Config -> DynFlags -> ModSummary -> m () +compile cfg dynflags modSummary = do + fp <- liftIO $ fmap (genFingerprint myName targetpath) getArgs + should_recompile <- liftIO $ shouldRecompile fp modSummary targetpath + when should_recompile $ do + case ms_hsc_src modSummary of + HsBootFile -> liftIO $ logStr $ "Skipping boot " ++ myName + _ -> do + (pgm, name) <- prepare dynflags modSummary + let pkgid = showPpr dynflags $ modulePackageId $ ms_mod modSummary + theCode = generate cfg fp pkgid name pgm + liftIO $ logStr $ "Compiling " ++ myName ++ " into " ++ targetpath + liftIO $ writeModule targetpath theCode + where + myName = moduleNameString $ moduleName $ ms_mod modSummary + targetpath = targetLibPath cfg + +shouldRecompile :: Fingerprint -> ModSummary -> FilePath -> IO Bool +shouldRecompile _ _ _ = return True +{- +shouldRecompile fp ms path = do + exists <- isFile fpPath + if exists + then do + fp' <- readModuleFingerprint path pkgid modname + jsmtime <- getModified fpPath + return $ ms_hs_date ms > jsmtime || fp /= fp' + else do + return True + where + modname = moduleNameString $ ms_mod_name ms + file = moduleNameSlashes (ms_mod_name ms) ++ ".jsmod" + path' = path ++ "/" ++ pkgid ++ "/" ++ file + pkgid = showOutputable $ modulePackageId $ ms_mod ms + fpPath = fromString path' +-} diff --git a/src/haste-boot.hs b/src/haste-boot.hs new file mode 100644 --- /dev/null +++ b/src/haste-boot.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE CPP #-} +import Prelude hiding (read) +import System.Directory +import Network.HTTP +import Network.Browser hiding (err) +import Network.URI +import qualified Data.ByteString.Lazy as BS +import Data.Version +import Data.Maybe (fromJust) +import Codec.Compression.BZip +import Codec.Archive.Tar +import System.Environment (getArgs) +import System.IO.Temp +import Control.Monad +import qualified Codec.Archive.Zip as Zip +import Haste.Environment +import Haste.Version +import Control.Shell +import Data.Char (isDigit) + +downloadFile :: String -> IO (Either String BS.ByteString) +downloadFile f = do + (_, rsp) <- Network.Browser.browse $ do + setAllowRedirects True + request $ Request { + rqURI = fromJust $ parseURI f, + rqMethod = GET, + rqHeaders = [], + rqBody = BS.empty + } + case rspCode rsp of + (2, _, _) -> return $ Right $ rspBody rsp + _ -> return $ Left $ rspReason rsp + +data Cfg = Cfg { + getLibs :: Bool, + getClosure :: Bool, + useLocalLibs :: Bool + } + +main :: IO () +main = do + args <- getArgs + -- Always get base and closure when forced unless explicitly asked not to; + -- if not forced, get base and closure when necessary, unless asked not to. + let forceBoot = elem "--force" args + libs = if elem "--no-libs" args + then False + else forceBoot || needsReboot + closure = if elem "--no-closure" args + then False + else forceBoot || needsReboot + local = elem "--local" args + cfg = Cfg { + getLibs = libs, + getClosure = closure, + useLocalLibs = local + } + + when (needsReboot || forceBoot) $ do + if local + then bootHaste cfg "." + else withSystemTempDirectory "haste" $ bootHaste cfg + +bootHaste :: Cfg -> FilePath -> IO () +bootHaste cfg tmpdir = do + setCurrentDirectory tmpdir + when (getLibs cfg) $ do + when (not $ useLocalLibs cfg) $ do + fetchLibs tmpdir + exists <- doesDirectoryExist hasteDir + when exists $ do + removeDirectoryRecursive hasteDir + buildLibs + when (getClosure cfg) $ do + installClosure + Prelude.writeFile bootFile (show bootVersion) + +-- | Fetch the Haste base libs. +fetchLibs :: FilePath -> IO () +fetchLibs tmpdir = do + putStrLn "Downloading base libs from ekblad.cc" + res <- downloadFile $ mkUrl hasteVersion + case res of + Left err -> + error $ "Unable to download base libs: " ++ err + Right f -> + unpack tmpdir . read . decompress $ f + where + mkUrl v = + "http://ekblad.cc/haste-libs/haste-libs-" ++ showVersion v ++ ".tar.bz2" + +-- | Fetch and install the Closure compiler. +installClosure :: IO () +installClosure = do + putStrLn "Downloading Google Closure compiler..." + closure <- downloadFile closureURI + case closure of + Left _ -> + putStrLn "Couldn't download Closure compiler; continuing without." + Right closure' -> do + let cloArch = Zip.toArchive closure' + case Zip.findEntryByPath "compiler.jar" cloArch of + Just compiler -> + BS.writeFile closureCompiler + (Zip.fromEntry compiler) + _ -> + putStrLn "Couldn't unpack Closure compiler; continuing without." + where + closureURI = + "http://closure-compiler.googlecode.com/files/compiler-latest.zip" + +-- | Build haste's base libs. +buildLibs :: IO () +buildLibs = do + res <- shell $ do + -- Set up dirs and copy includes + mkdir True $ pkgLibDir + cpDir "include" hasteDir + run_ "haste-pkg" ["update", "libraries" "rts.pkg"] "" + + inDirectory "libraries" $ do + -- Install ghc-prim + inDirectory "ghc-prim" $ do + hasteInst ["configure"] + hasteInst ["build", "--install-jsmods", ghcOpts] + run_ "haste-install-his" ["ghc-prim-0.3.0.0", "dist" "build"] "" + run_ "haste-pkg" ["update", "packageconfig"] "" + + -- Install integer-gmp twice, since it may misbehave the first time. + inDirectory "integer-gmp" $ do + hasteInst ["install", ghcOpts] + hasteInst ["install", ghcOpts] + + -- Install base + inDirectory "base" $ do + basever <- file "base.cabal" >>= return + . dropWhile (not . isDigit) + . head + . filter (not . null) + . filter (and . zipWith (==) "version") + . lines + hasteInst ["configure"] + hasteInst ["build", "--install-jsmods", ghcOpts] + let base = "base-" ++ basever + pkgdb = "--package-db=dist" "package.conf.inplace" + run_ "haste-install-his" [base, "dist" "build"] "" + run_ "haste-copy-pkg" [base, pkgdb] "" + + -- Install array, fursuit and haste-lib + forM_ ["array", "fursuit", "haste-lib"] $ \pkg -> do + inDirectory pkg $ hasteInst ["install"] + case res of + Left err -> error err + _ -> return () + where + ghcOpts = + "--ghc-options=-DHASTE_HOST_WORD_SIZE_IN_BITS=" ++ show hostWordSize + hasteInst args = + run_ "haste-inst" ("--unbooted" : args) "" diff --git a/src/haste-copy-pkg.hs b/src/haste-copy-pkg.hs new file mode 100644 --- /dev/null +++ b/src/haste-copy-pkg.hs @@ -0,0 +1,56 @@ +-- | haste-copy-pkg; copy a package from file or GHC package DB and fix up its +-- paths. +module Main where +import Data.List +import Haste.Environment +import System.Environment (getArgs) +import Control.Shell + +main :: IO () +main = do + args <- getArgs + let (pkgdbs, pkgs) = partition ("--package-db=" `isPrefixOf`) args + if null args + then do + putStrLn "Usage: haste-copy-pkg [--package-db=foo.conf] " + else do + res <- shell (mapM_ (copyFromDB pkgdbs) pkgs) + case res of + Left err -> error err + _ -> return () + +copyFromDB :: [String] -> String -> Shell () +copyFromDB pkgdbs package = do + pkgdesc <- run "ghc-pkg" (["describe", package] ++ pkgdbs) "" + run_ "haste-pkg" ["update", "-", "--force"] (fixPaths package pkgdesc) + +-- | Hack a config to work with Haste. +fixPaths :: String -> String -> String +fixPaths pkgname pkgtext = + pkgtext' + where + pkgtext' = unlines + . map fixPath + . filter (not . ("haddock" `isPrefixOf`)) + . filter (not . ("hs-libraries:" `isPrefixOf`)) + $ lines pkgtext + + fixPath str + | isKey "library-dirs:" str = + "library-dirs: " ++ importDir pkgname + | isKey "import-dirs:" str = + "import-dirs: " ++ importDir pkgname + | isKey "pkgroot:" str = + "pkgroot: \"" ++ pkgRoot ++ "\"" + | "-inplace" `isSuffixOf` str = + reverse $ drop (length "-inplace") $ reverse str + | otherwise = + str + + isKey _ "" = + False + isKey key str = + and $ zipWith (==) key str + + importDir = pkgLibDir + pkgRoot = hasteInstDir diff --git a/src/haste-inst.hs b/src/haste-inst.hs new file mode 100644 --- /dev/null +++ b/src/haste-inst.hs @@ -0,0 +1,36 @@ +-- | haste-inst - Haste wrapper for cabal. +module Main where +import System.FilePath +import System.Environment +import Haste.Environment +import Data.List + +type Match = (String -> Bool, [String] -> [String]) + +cabal :: [String] -> IO () +cabal args = do + runAndWait "cabal" (hasteargs ++ args) Nothing + where + hasteargs + | "build" `elem` args = + ["--with-ghc=" ++ hasteBinary] + | otherwise = + ["--with-compiler=" ++ hasteBinary, + "--with-hc-pkg=" ++ hastePkgBinary, + "--with-hsc2hs=hsc2hs", + "--prefix=" ++ hasteInstDir, + "--package-db=" ++ pkgDir] + +main :: IO () +main = do + as <- getArgs + as <- return $ if "--install-jsmods" `elem` as || not ("build" `elem` as) + then libinstall : filter (/= "--install-jsmods") as + else as + as <- return $ if "--unbooted" `elem` as + then unbooted : filter (/= "--unbooted") as + else as + cabal as + where + libinstall = "--ghc-option=--libinstall" + unbooted = "--ghc-option=--unbooted" diff --git a/src/haste-install-his.hs b/src/haste-install-his.hs new file mode 100644 --- /dev/null +++ b/src/haste-install-his.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TupleSections #-} +-- | haste-install-his; install all .hi files in a directory. +module Main where +import Haste.Environment +import System.FilePath +import System.Directory +import System.Environment +import Control.Applicative +import Control.Monad +import Data.List +import Data.Char + +main :: IO () +main = do + args <- getArgs + case args of + [package, dir] -> installFromDir (pkgLibDir package) dir + _ -> putStrLn "Usage: haste-install-his pkgname dir" + +getHiFiles :: FilePath -> IO [FilePath] +getHiFiles dir = + filter (".hi" `isSuffixOf`) <$> getDirectoryContents dir + +getSubdirs :: FilePath -> IO [FilePath] +getSubdirs dir = do + contents <- getDirectoryContents dir + someDirs <- mapM (\d -> (d,) <$> doesDirectoryExist (dir d)) contents + return [path | (path, isDir) <- someDirs + , isDir + , head path /= '.' + , isUpper (head path)] + +installFromDir :: FilePath -> FilePath -> IO () +installFromDir base path = do + hiFiles <- getHiFiles path + when (not $ null hiFiles) $ do + createDirectoryIfMissing True (pkgLibDir base) + mapM_ (installHiFile base path) hiFiles + getSubdirs path >>= mapM_ (\d -> installFromDir (base d) (path d)) + +installHiFile :: FilePath -> FilePath -> FilePath -> IO () +installHiFile to from file = do + putStrLn $ "Installing " ++ from file ++ "..." + copyFile (from file) (to file) diff --git a/src/haste-pkg.hs b/src/haste-pkg.hs new file mode 100644 --- /dev/null +++ b/src/haste-pkg.hs @@ -0,0 +1,19 @@ +-- | haste-pkg; wrapper for ghc-pkg. +module Main where +import Control.Monad +import System.Environment +import System.Directory +import Haste.Environment + +main = do + args <- getArgs + pkgDirExists <- doesDirectoryExist pkgDir + when (not pkgDirExists) $ do + createDirectoryIfMissing True pkgLibDir + runAndWait "ghc-pkg" ["init", pkgDir] Nothing + runAndWait "ghc-pkg" (packages ++ map userToGlobal args) Nothing + where + packages = ["--no-user-package-db", + "--global-package-db=" ++ pkgDir] + userToGlobal "--user" = "--global" + userToGlobal str = str