diff --git a/haste-compiler.cabal b/haste-compiler.cabal --- a/haste-compiler.cabal +++ b/haste-compiler.cabal @@ -1,5 +1,5 @@ Name: haste-compiler -Version: 0.5.2 +Version: 0.5.3 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler @@ -25,12 +25,13 @@ lib Data-Files: + bn.js rts.js stdlib.js MVar.js StableName.js Integer.js - Int64.js + long.js md5.js array.js pointers.js @@ -92,7 +93,7 @@ network, network-uri, HTTP, - shellmate >= 0.1.5, + shellmate >= 0.2.3 && <0.3, ghc-paths, ghc, directory, @@ -120,23 +121,32 @@ mtl, binary, containers, - data-default, bytestring >= 0.10.4, utf8-string, array, ghc-paths, random, system-fileio, - shellmate >= 0.1.5, + shellmate >= 0.2.3 && <0.3, either, filepath, directory, - ghc-simple >= 0.1.2.1 + ghc-simple >= 0.3 && < 0.4 Main-Is: hastec.hs Other-Modules: - Haste Haste.Args + Haste.AST + Haste.AST.Syntax + Haste.AST.Binary + Haste.AST.Constructors + Haste.AST.FlowAnalysis + Haste.AST.Op + Haste.AST.Optimize + Haste.AST.PP + Haste.AST.PP.Opts + Haste.AST.Print + Haste.AST.Traversal Haste.Opts Haste.Version Haste.Environment @@ -150,15 +160,6 @@ Haste.Errors Haste.CodeGen Haste.JSLib - 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-pkg @@ -194,7 +195,7 @@ binary, bin-package-db, bytestring, - shellmate, + shellmate >= 0.2.3 && <0.3, ghc if !os(windows) Build-Depends: unix, @@ -220,7 +221,7 @@ GHC-Options: -static -optl-static -optl-pthread Build-Depends: base < 5, - shellmate >= 0.1.5, + shellmate >= 0.2.2 && <0.3, ghc-paths, ghc, binary, @@ -229,7 +230,6 @@ bytestring, array, random, - data-default, mtl, directory, utf8-string @@ -301,8 +301,7 @@ bytestring, utf8-string, -- For Haste.Compiler - shellmate >= 0.1.5, - data-default, + shellmate >= 0.2.2 && <0.3, directory, filepath, process, diff --git a/lib/Foreign.js b/lib/Foreign.js --- a/lib/Foreign.js +++ b/lib/Foreign.js @@ -9,8 +9,8 @@ var __apply = function(f,as) { var arr = []; - for(; as[0] === 1; as = as[2]) { - arr.push(as[1]); + for(; as._ === 1; as = as.b) { + arr.push(as.a); } arr.reverse(); return f.apply(null, arr); @@ -53,16 +53,18 @@ function __arr2lst(elem,arr) { if(elem >= arr.length) { - return [0]; + return __Z; } - return [1, arr[elem],new T(function(){return __arr2lst(elem+1,arr);})] + return {_:1, + a:arr[elem], + b:new T(function(){return __arr2lst(elem+1,arr);})}; } function __lst2arr(xs) { var arr = []; xs = E(xs); - for(;xs[0] === 1; xs = E(xs[2])) { - arr.push(E(xs[1])); + for(;xs._ === 1; xs = E(xs.b)) { + arr.push(E(xs.a)); } return arr; } diff --git a/lib/Int64.js b/lib/Int64.js deleted file mode 100644 --- a/lib/Int64.js +++ /dev/null @@ -1,458 +0,0 @@ -// Copyright 2009 The Closure Library Authors. All Rights Reserved. -// -// Licensed under the Apache License, Version 2.0 (the "License"); -// you may not use this file except in compliance with the License. -// You may obtain a copy of the License at -// -// http://www.apache.org/licenses/LICENSE-2.0 -// -// Unless required by applicable law or agreed to in writing, software -// distributed under the License is distributed on an "AS-IS" BASIS, -// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -// See the License for the specific language governing permissions and -// limitations under the License. - -var Long = function(low, high) { - this.low_ = low | 0; - this.high_ = high | 0; -}; - -Long.IntCache_ = {}; - -Long.fromInt = function(value) { - if (-128 <= value && value < 128) { - var cachedObj = Long.IntCache_[value]; - if (cachedObj) { - return cachedObj; - } - } - - var obj = new Long(value | 0, value < 0 ? -1 : 0); - if (-128 <= value && value < 128) { - Long.IntCache_[value] = obj; - } - return obj; -}; - -Long.fromNumber = function(value) { - if (isNaN(value) || !isFinite(value)) { - return Long.ZERO; - } else if (value <= -Long.TWO_PWR_63_DBL_) { - return Long.MIN_VALUE; - } else if (value + 1 >= Long.TWO_PWR_63_DBL_) { - return Long.MAX_VALUE; - } else if (value < 0) { - return Long.fromNumber(-value).negate(); - } else { - return new Long( - (value % Long.TWO_PWR_32_DBL_) | 0, - (value / Long.TWO_PWR_32_DBL_) | 0); - } -}; - -Long.fromBits = function(lowBits, highBits) { - return new Long(lowBits, highBits); -}; - -Long.TWO_PWR_16_DBL_ = 1 << 16; -Long.TWO_PWR_24_DBL_ = 1 << 24; -Long.TWO_PWR_32_DBL_ = - Long.TWO_PWR_16_DBL_ * Long.TWO_PWR_16_DBL_; -Long.TWO_PWR_31_DBL_ = - Long.TWO_PWR_32_DBL_ / 2; -Long.TWO_PWR_48_DBL_ = - Long.TWO_PWR_32_DBL_ * Long.TWO_PWR_16_DBL_; -Long.TWO_PWR_64_DBL_ = - Long.TWO_PWR_32_DBL_ * Long.TWO_PWR_32_DBL_; -Long.TWO_PWR_63_DBL_ = - Long.TWO_PWR_64_DBL_ / 2; -Long.ZERO = Long.fromInt(0); -Long.ONE = Long.fromInt(1); -Long.NEG_ONE = Long.fromInt(-1); -Long.MAX_VALUE = - Long.fromBits(0xFFFFFFFF | 0, 0x7FFFFFFF | 0); -Long.MIN_VALUE = Long.fromBits(0, 0x80000000 | 0); -Long.TWO_PWR_24_ = Long.fromInt(1 << 24); - -Long.prototype.toInt = function() { - return this.low_; -}; - -Long.prototype.toNumber = function() { - return this.high_ * Long.TWO_PWR_32_DBL_ + - this.getLowBitsUnsigned(); -}; - -Long.prototype.getHighBits = function() { - return this.high_; -}; - -Long.prototype.getLowBits = function() { - return this.low_; -}; - -Long.prototype.getLowBitsUnsigned = function() { - return (this.low_ >= 0) ? - this.low_ : Long.TWO_PWR_32_DBL_ + this.low_; -}; - -Long.prototype.isZero = function() { - return this.high_ == 0 && this.low_ == 0; -}; - -Long.prototype.isNegative = function() { - return this.high_ < 0; -}; - -Long.prototype.isOdd = function() { - return (this.low_ & 1) == 1; -}; - -Long.prototype.equals = function(other) { - return (this.high_ == other.high_) && (this.low_ == other.low_); -}; - -Long.prototype.notEquals = function(other) { - return (this.high_ != other.high_) || (this.low_ != other.low_); -}; - -Long.prototype.lessThan = function(other) { - return this.compare(other) < 0; -}; - -Long.prototype.lessThanOrEqual = function(other) { - return this.compare(other) <= 0; -}; - -Long.prototype.greaterThan = function(other) { - return this.compare(other) > 0; -}; - -Long.prototype.greaterThanOrEqual = function(other) { - return this.compare(other) >= 0; -}; - -Long.prototype.compare = function(other) { - if (this.equals(other)) { - return 0; - } - - var thisNeg = this.isNegative(); - var otherNeg = other.isNegative(); - if (thisNeg && !otherNeg) { - return -1; - } - if (!thisNeg && otherNeg) { - return 1; - } - - if (this.subtract(other).isNegative()) { - return -1; - } else { - return 1; - } -}; - -Long.prototype.negate = function() { - if (this.equals(Long.MIN_VALUE)) { - return Long.MIN_VALUE; - } else { - return this.not().add(Long.ONE); - } -}; - -Long.prototype.add = function(other) { - var a48 = this.high_ >>> 16; - var a32 = this.high_ & 0xFFFF; - var a16 = this.low_ >>> 16; - var a00 = this.low_ & 0xFFFF; - - var b48 = other.high_ >>> 16; - var b32 = other.high_ & 0xFFFF; - var b16 = other.low_ >>> 16; - var b00 = other.low_ & 0xFFFF; - - var c48 = 0, c32 = 0, c16 = 0, c00 = 0; - c00 += a00 + b00; - c16 += c00 >>> 16; - c00 &= 0xFFFF; - c16 += a16 + b16; - c32 += c16 >>> 16; - c16 &= 0xFFFF; - c32 += a32 + b32; - c48 += c32 >>> 16; - c32 &= 0xFFFF; - c48 += a48 + b48; - c48 &= 0xFFFF; - return Long.fromBits((c16 << 16) | c00, (c48 << 16) | c32); -}; - -Long.prototype.subtract = function(other) { - return this.add(other.negate()); -}; - -Long.prototype.multiply = function(other) { - if (this.isZero()) { - return Long.ZERO; - } else if (other.isZero()) { - return Long.ZERO; - } - - if (this.equals(Long.MIN_VALUE)) { - return other.isOdd() ? Long.MIN_VALUE : Long.ZERO; - } else if (other.equals(Long.MIN_VALUE)) { - return this.isOdd() ? Long.MIN_VALUE : Long.ZERO; - } - - if (this.isNegative()) { - if (other.isNegative()) { - return this.negate().multiply(other.negate()); - } else { - return this.negate().multiply(other).negate(); - } - } else if (other.isNegative()) { - return this.multiply(other.negate()).negate(); - } - - if (this.lessThan(Long.TWO_PWR_24_) && - other.lessThan(Long.TWO_PWR_24_)) { - return Long.fromNumber(this.toNumber() * other.toNumber()); - } - - var a48 = this.high_ >>> 16; - var a32 = this.high_ & 0xFFFF; - var a16 = this.low_ >>> 16; - var a00 = this.low_ & 0xFFFF; - - var b48 = other.high_ >>> 16; - var b32 = other.high_ & 0xFFFF; - var b16 = other.low_ >>> 16; - var b00 = other.low_ & 0xFFFF; - - var c48 = 0, c32 = 0, c16 = 0, c00 = 0; - c00 += a00 * b00; - c16 += c00 >>> 16; - c00 &= 0xFFFF; - c16 += a16 * b00; - c32 += c16 >>> 16; - c16 &= 0xFFFF; - c16 += a00 * b16; - c32 += c16 >>> 16; - c16 &= 0xFFFF; - c32 += a32 * b00; - c48 += c32 >>> 16; - c32 &= 0xFFFF; - c32 += a16 * b16; - c48 += c32 >>> 16; - c32 &= 0xFFFF; - c32 += a00 * b32; - c48 += c32 >>> 16; - c32 &= 0xFFFF; - c48 += a48 * b00 + a32 * b16 + a16 * b32 + a00 * b48; - c48 &= 0xFFFF; - return Long.fromBits((c16 << 16) | c00, (c48 << 16) | c32); -}; - -Long.prototype.div = function(other) { - if (other.isZero()) { - throw Error('division by zero'); - } else if (this.isZero()) { - return Long.ZERO; - } - - if (this.equals(Long.MIN_VALUE)) { - if (other.equals(Long.ONE) || - other.equals(Long.NEG_ONE)) { - return Long.MIN_VALUE; - } else if (other.equals(Long.MIN_VALUE)) { - return Long.ONE; - } else { - var halfThis = this.shiftRight(1); - var approx = halfThis.div(other).shiftLeft(1); - if (approx.equals(Long.ZERO)) { - return other.isNegative() ? Long.ONE : Long.NEG_ONE; - } else { - var rem = this.subtract(other.multiply(approx)); - var result = approx.add(rem.div(other)); - return result; - } - } - } else if (other.equals(Long.MIN_VALUE)) { - return Long.ZERO; - } - - if (this.isNegative()) { - if (other.isNegative()) { - return this.negate().div(other.negate()); - } else { - return this.negate().div(other).negate(); - } - } else if (other.isNegative()) { - return this.div(other.negate()).negate(); - } - - var res = Long.ZERO; - var rem = this; - while (rem.greaterThanOrEqual(other)) { - var approx = Math.max(1, Math.floor(rem.toNumber() / other.toNumber())); - - var log2 = Math.ceil(Math.log(approx) / Math.LN2); - var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48); - - var approxRes = Long.fromNumber(approx); - var approxRem = approxRes.multiply(other); - while (approxRem.isNegative() || approxRem.greaterThan(rem)) { - approx -= delta; - approxRes = Long.fromNumber(approx); - approxRem = approxRes.multiply(other); - } - - if (approxRes.isZero()) { - approxRes = Long.ONE; - } - - res = res.add(approxRes); - rem = rem.subtract(approxRem); - } - return res; -}; - -Long.prototype.modulo = function(other) { - return this.subtract(this.div(other).multiply(other)); -}; - -Long.prototype.not = function() { - return Long.fromBits(~this.low_, ~this.high_); -}; - -Long.prototype.and = function(other) { - return Long.fromBits(this.low_ & other.low_, - this.high_ & other.high_); -}; - -Long.prototype.or = function(other) { - return Long.fromBits(this.low_ | other.low_, - this.high_ | other.high_); -}; - -Long.prototype.xor = function(other) { - return Long.fromBits(this.low_ ^ other.low_, - this.high_ ^ other.high_); -}; - -Long.prototype.shiftLeft = function(numBits) { - numBits &= 63; - if (numBits == 0) { - return this; - } else { - var low = this.low_; - if (numBits < 32) { - var high = this.high_; - return Long.fromBits( - low << numBits, - (high << numBits) | (low >>> (32 - numBits))); - } else { - return Long.fromBits(0, low << (numBits - 32)); - } - } -}; - -Long.prototype.shiftRight = function(numBits) { - numBits &= 63; - if (numBits == 0) { - return this; - } else { - var high = this.high_; - if (numBits < 32) { - var low = this.low_; - return Long.fromBits( - (low >>> numBits) | (high << (32 - numBits)), - high >> numBits); - } else { - return Long.fromBits( - high >> (numBits - 32), - high >= 0 ? 0 : -1); - } - } -}; - -Long.prototype.shiftRightUnsigned = function(numBits) { - numBits &= 63; - if (numBits == 0) { - return this; - } else { - var high = this.high_; - if (numBits < 32) { - var low = this.low_; - return Long.fromBits( - (low >>> numBits) | (high << (32 - numBits)), - high >>> numBits); - } else if (numBits == 32) { - return Long.fromBits(high, 0); - } else { - return Long.fromBits(high >>> (numBits - 32), 0); - } - } -}; - - - -// Int64 -function hs_eqInt64(x, y) {return x.equals(y);} -function hs_neInt64(x, y) {return !x.equals(y);} -function hs_ltInt64(x, y) {return x.compare(y) < 0;} -function hs_leInt64(x, y) {return x.compare(y) <= 0;} -function hs_gtInt64(x, y) {return x.compare(y) > 0;} -function hs_geInt64(x, y) {return x.compare(y) >= 0;} -function hs_quotInt64(x, y) {return x.div(y);} -function hs_remInt64(x, y) {return x.modulo(y);} -function hs_plusInt64(x, y) {return x.add(y);} -function hs_minusInt64(x, y) {return x.subtract(y);} -function hs_timesInt64(x, y) {return x.multiply(y);} -function hs_negateInt64(x) {return x.negate();} -function hs_uncheckedIShiftL64(x, bits) {return x.shiftLeft(bits);} -function hs_uncheckedIShiftRA64(x, bits) {return x.shiftRight(bits);} -function hs_uncheckedIShiftRL64(x, bits) {return x.shiftRightUnsigned(bits);} -function hs_intToInt64(x) {return new Long(x, 0);} -function hs_int64ToInt(x) {return x.toInt();} - - - -// Word64 -function hs_wordToWord64(x) { - return I_fromInt(x); -} -function hs_word64ToWord(x) { - return I_toInt(x); -} -function hs_mkWord64(low, high) { - return I_fromBits([low, high]); -} - -var hs_and64 = I_and; -var hs_or64 = I_or; -var hs_xor64 = I_xor; -var __i64_all_ones = I_fromBits([0xffffffff, 0xffffffff]); -function hs_not64(x) { - return I_xor(x, __i64_all_ones); -} -var hs_eqWord64 = I_equals; -var hs_neWord64 = I_notEquals; -var hs_ltWord64 = I_lessThan; -var hs_leWord64 = I_lessThanOrEqual; -var hs_gtWord64 = I_greaterThan; -var hs_geWord64 = I_greaterThanOrEqual; -var hs_quotWord64 = I_quot; -var hs_remWord64 = I_rem; -var __w64_max = I_fromBits([0,0,1]); -function hs_uncheckedShiftL64(x, bits) { - return I_rem(I_shiftLeft(x, bits), __w64_max); -} -var hs_uncheckedShiftRL64 = I_shiftRight; -function hs_int64ToWord64(x) { - var tmp = I_add(__w64_max, I_fromBits([x.getLowBits(), x.getHighBits()])); - return I_rem(tmp, __w64_max); -} -function hs_word64ToInt64(x) { - return Long.fromBits(I_getBits(x, 0), I_getBits(x, 1)); -} diff --git a/lib/Integer.js b/lib/Integer.js --- a/lib/Integer.js +++ b/lib/Integer.js @@ -1,522 +1,88 @@ -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); - } -}; - -var I_fromBits = function(bits) { - var high = bits[bits.length - 1]; - return new Integer(bits, high & (1 << 31) ? -1 : 0); -}; - -var 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(result, 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 += I_getBitsUnsigned(self, i) * pow; - pow *= Integer.TWO_PWR_32_DBL_; - } - return val; - } -}; - -var I_getBits = function(self, index) { - if (index < 0) { - return 0; - } else if (index < self.bits_.length) { - return self.bits_[index]; - } else { - return self.sign_; - } -}; - -var I_getBitsUnsigned = function(self, index) { - var val = I_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 (I_getBits(self, i) != I_getBits(other, i)) { - return false; - } - } - return true; -}; - -var I_notEquals = function(self, other) { - return !I_equals(self, other); -}; - -var I_greaterThan = function(self, other) { - return I_compare(self, other) > 0; -}; - -var I_greaterThanOrEqual = function(self, other) { - return I_compare(self, other) >= 0; -}; - -var I_lessThan = function(self, other) { - return I_compare(self, other) < 0; -}; - -var I_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)); +// TODO: inefficient compared to real fromInt? +__bn.Z = new __bn.BN(0); +__bn.ONE = new __bn.BN(1); +__bn.MOD32 = new __bn.BN(0x100000000); // 2^32 +var I_fromNumber = function(x) {return new __bn.BN(x);} +var I_fromInt = I_fromNumber; +var I_fromBits = function(lo,hi) { + var x = new __bn.BN(lo >>> 0); + var y = new __bn.BN(hi >>> 0); + y.ishln(32); + x.iadd(y); + return x; } - -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] = I_getBits(self, i); - } - var sigBits = bit_index == 31 ? 0xFFFFFFFF : (1 << (bit_index + 1)) - 1; - var val = I_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 = I_getBits(self, i) >>> 16; - var a0 = I_getBits(self, i) & 0xFFFF; - - var b1 = I_getBits(other, i) >>> 16; - var b0 = I_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 I_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 (I_lessThan(self, Integer.TWO_PWR_24_) && - I_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 = I_getBits(self, i) >>> 16; - var a0 = I_getBits(self, i) & 0xFFFF; - - var b1 = I_getBits(other, j) >>> 16; - var b0 = I_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_fromString = function(s) {return new __bn.BN(s);} +var I_toInt = function(x) {return I_toNumber(x.mod(__bn.MOD32));} +var I_toWord = function(x) {return I_toInt(x) >>> 0;}; +// TODO: inefficient! +var I_toNumber = function(x) {return Number(x.toString());} +var I_equals = function(a,b) {return a.cmp(b) === 0;} +var I_compare = function(a,b) {return a.cmp(b);} +var I_compareInt = function(x,i) {return x.cmp(new __bn.BN(i));} +var I_negate = function(x) {return x.neg();} +var I_add = function(a,b) {return a.add(b);} +var I_sub = function(a,b) {return a.sub(b);} +var I_mul = function(a,b) {return a.mul(b);} +var I_mod = function(a,b) {return I_rem(I_add(b, I_rem(a, b)), b);} +var I_quotRem = function(a,b) { + var qr = a.divmod(b); + return {_:0, a:qr.div, b:qr.mod}; } - -var I_div = function(self, other) { - if(I_greaterThan(self, Integer.ZERO) != I_greaterThan(other, Integer.ZERO)) { - if(I_rem(self, other) != Integer.ZERO) { - return I_sub(I_quot(self, other), Integer.ONE); +var I_div = function(a,b) { + if((a.cmp(__bn.Z)>=0) != (a.cmp(__bn.Z)>=0)) { + if(a.cmp(a.rem(b), __bn.Z) !== 0) { + return a.div(b).sub(__bn.ONE); + } } - } - return I_quot(self, other); -} - -var I_quotRem = function(self, other) { - return [0, I_quot(self, other), I_rem(self, other)]; + return a.div(b); } - -var I_divMod = function(self, other) { - return [0, I_div(self, other), I_mod(self, other)]; +var I_divMod = function(a,b) { + return {_:0, a:I_div(self, other), b:a.mod(b)}; } - -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 (I_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) || I_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] = I_getBits(self, i) & 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] = I_getBits(self, i) | 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] = I_getBits(self, i) ^ 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] = (I_getBits(self, i - arr_delta) << bit_delta) | - (I_getBits(self, i - arr_delta - 1) >>> (32 - bit_delta)); - } else { - arr[i] = 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] = (I_getBits(self, i + arr_delta) >>> bit_delta) | - (I_getBits(self, i + arr_delta + 1) << (32 - bit_delta)); - } else { - arr[i] = 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_quot = function(a,b) {return a.div(b);} +var I_rem = function(a,b) {return a.mod(b);} +var I_and = function(a,b) {return a.and(b);} +var I_or = function(a,b) {return a.or(b);} +var I_xor = function(a,b) {return a.xor(b);} +var I_shiftLeft = function(a,b) {return a.shln(b);} +var I_shiftRight = function(a,b) {return a.shrn(b);} +var I_signum = function(x) {return x.cmp(new __bn.BN(0));} +var I_abs = function(x) {return x.abs();} var I_decodeDouble = function(x) { - var dec = decodeDouble(x); - var mantissa = I_fromBits([dec[3], dec[2]]); - if(dec[1] < 0) { - mantissa = I_negate(mantissa); - } - return [0, 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 dec = decodeDouble(x); + var mantissa = I_fromBits(dec.c, dec.b); + if(dec.a < 0) { + mantissa = I_negate(mantissa); } - } -}; - + return {_:0, a:dec.d, b:mantissa}; +} +var I_toString = function(x) {return x.toString();} var I_fromRat = function(a, b) { return I_toNumber(a) / I_toNumber(b); } function I_fromInt64(x) { - return I_fromBits([x.getLowBits(), x.getHighBits()]); + if(x.isNegative()) { + return I_negate(I_fromInt64(x.negate())); + } else { + return I_fromBits(x.low, x.high); + } } function I_toInt64(x) { - return Long.fromBits(I_getBits(x, 0), I_getBits(x, 1)); + if(x.negative) { + return I_toInt64(I_negate(x)).negate(); + } else { + return new Long(I_toInt(x), I_toInt(I_shiftRight(x,32))); + } } function I_fromWord64(x) { - return x; + return I_fromBits(x.toInt(), x.shru(32).toInt()); } function I_toWord64(x) { - return I_rem(I_add(__w64_max, x), __w64_max); + var w = I_toInt64(x); + w.unsigned = true; + return w; } diff --git a/lib/MVar.js b/lib/MVar.js --- a/lib/MVar.js +++ b/lib/MVar.js @@ -9,12 +9,12 @@ function tryTakeMVar(mv) { if(mv.empty) { - return [0, 0, undefined]; + return {_:0, a:0, b:undefined}; } else { var val = mv.x; mv.empty = true; mv.x = null; - return [0, 1, val]; + return {_:0, a:1, b:val}; } } diff --git a/lib/Weak.js b/lib/Weak.js --- a/lib/Weak.js +++ b/lib/Weak.js @@ -7,9 +7,9 @@ } function derefWeak(w) { - return [0, 1, E(w).val]; + return {_:0, a:1, b:E(w).val}; } function finalizeWeak(w) { - return [0, B(A(E(w).fin, [0]))]; + return {_:0, a:B(A1(E(w).fin, __Z))}; } diff --git a/lib/bn.js b/lib/bn.js new file mode 100644 --- /dev/null +++ b/lib/bn.js @@ -0,0 +1,1460 @@ +/* bn.js by Fedor Indutny, see doc/LICENSE.bn for license */ +var __bn = {}; +(function (module, exports) { +'use strict'; + +function BN(number, base, endian) { + // May be `new BN(bn)` ? + if (number !== null && + typeof number === 'object' && + Array.isArray(number.words)) { + return number; + } + + this.negative = 0; + this.words = null; + this.length = 0; + + if (base === 'le' || base === 'be') { + endian = base; + base = 10; + } + + if (number !== null) + this._init(number || 0, base || 10, endian || 'be'); +} +if (typeof module === 'object') + module.exports = BN; +else + exports.BN = BN; + +BN.BN = BN; +BN.wordSize = 26; + +BN.max = function max(left, right) { + if (left.cmp(right) > 0) + return left; + else + return right; +}; + +BN.min = function min(left, right) { + if (left.cmp(right) < 0) + return left; + else + return right; +}; + +BN.prototype._init = function init(number, base, endian) { + if (typeof number === 'number') { + return this._initNumber(number, base, endian); + } else if (typeof number === 'object') { + return this._initArray(number, base, endian); + } + if (base === 'hex') + base = 16; + + number = number.toString().replace(/\s+/g, ''); + var start = 0; + if (number[0] === '-') + start++; + + if (base === 16) + this._parseHex(number, start); + else + this._parseBase(number, base, start); + + if (number[0] === '-') + this.negative = 1; + + this.strip(); + + if (endian !== 'le') + return; + + this._initArray(this.toArray(), base, endian); +}; + +BN.prototype._initNumber = function _initNumber(number, base, endian) { + if (number < 0) { + this.negative = 1; + number = -number; + } + if (number < 0x4000000) { + this.words = [ number & 0x3ffffff ]; + this.length = 1; + } else if (number < 0x10000000000000) { + this.words = [ + number & 0x3ffffff, + (number / 0x4000000) & 0x3ffffff + ]; + this.length = 2; + } else { + this.words = [ + number & 0x3ffffff, + (number / 0x4000000) & 0x3ffffff, + 1 + ]; + this.length = 3; + } + + if (endian !== 'le') + return; + + // Reverse the bytes + this._initArray(this.toArray(), base, endian); +}; + +BN.prototype._initArray = function _initArray(number, base, endian) { + if (number.length <= 0) { + this.words = [ 0 ]; + this.length = 1; + return this; + } + + this.length = Math.ceil(number.length / 3); + this.words = new Array(this.length); + for (var i = 0; i < this.length; i++) + this.words[i] = 0; + + var off = 0; + if (endian === 'be') { + for (var i = number.length - 1, j = 0; i >= 0; i -= 3) { + var w = number[i] | (number[i - 1] << 8) | (number[i - 2] << 16); + this.words[j] |= (w << off) & 0x3ffffff; + this.words[j + 1] = (w >>> (26 - off)) & 0x3ffffff; + off += 24; + if (off >= 26) { + off -= 26; + j++; + } + } + } else if (endian === 'le') { + for (var i = 0, j = 0; i < number.length; i += 3) { + var w = number[i] | (number[i + 1] << 8) | (number[i + 2] << 16); + this.words[j] |= (w << off) & 0x3ffffff; + this.words[j + 1] = (w >>> (26 - off)) & 0x3ffffff; + off += 24; + if (off >= 26) { + off -= 26; + j++; + } + } + } + return this.strip(); +}; + +function parseHex(str, start, end) { + var r = 0; + var len = Math.min(str.length, end); + for (var i = start; i < len; i++) { + var c = str.charCodeAt(i) - 48; + + r <<= 4; + + // 'a' - 'f' + if (c >= 49 && c <= 54) + r |= c - 49 + 0xa; + + // 'A' - 'F' + else if (c >= 17 && c <= 22) + r |= c - 17 + 0xa; + + // '0' - '9' + else + r |= c & 0xf; + } + return r; +} + +BN.prototype._parseHex = function _parseHex(number, start) { + // Create possibly bigger array to ensure that it fits the number + this.length = Math.ceil((number.length - start) / 6); + this.words = new Array(this.length); + for (var i = 0; i < this.length; i++) + this.words[i] = 0; + + // Scan 24-bit chunks and add them to the number + var off = 0; + for (var i = number.length - 6, j = 0; i >= start; i -= 6) { + var w = parseHex(number, i, i + 6); + this.words[j] |= (w << off) & 0x3ffffff; + this.words[j + 1] |= w >>> (26 - off) & 0x3fffff; + off += 24; + if (off >= 26) { + off -= 26; + j++; + } + } + if (i + 6 !== start) { + var w = parseHex(number, start, i + 6); + this.words[j] |= (w << off) & 0x3ffffff; + this.words[j + 1] |= w >>> (26 - off) & 0x3fffff; + } + this.strip(); +}; + +function parseBase(str, start, end, mul) { + var r = 0; + var len = Math.min(str.length, end); + for (var i = start; i < len; i++) { + var c = str.charCodeAt(i) - 48; + + r *= mul; + + // 'a' + if (c >= 49) + r += c - 49 + 0xa; + + // 'A' + else if (c >= 17) + r += c - 17 + 0xa; + + // '0' - '9' + else + r += c; + } + return r; +} + +BN.prototype._parseBase = function _parseBase(number, base, start) { + // Initialize as zero + this.words = [ 0 ]; + this.length = 1; + + // Find length of limb in base + for (var limbLen = 0, limbPow = 1; limbPow <= 0x3ffffff; limbPow *= base) + limbLen++; + limbLen--; + limbPow = (limbPow / base) | 0; + + var total = number.length - start; + var mod = total % limbLen; + var end = Math.min(total, total - mod) + start; + + var word = 0; + for (var i = start; i < end; i += limbLen) { + word = parseBase(number, i, i + limbLen, base); + + this.imuln(limbPow); + if (this.words[0] + word < 0x4000000) + this.words[0] += word; + else + this._iaddn(word); + } + + if (mod !== 0) { + var pow = 1; + var word = parseBase(number, i, number.length, base); + + for (var i = 0; i < mod; i++) + pow *= base; + this.imuln(pow); + if (this.words[0] + word < 0x4000000) + this.words[0] += word; + else + this._iaddn(word); + } +}; + +BN.prototype.copy = function copy(dest) { + dest.words = new Array(this.length); + for (var i = 0; i < this.length; i++) + dest.words[i] = this.words[i]; + dest.length = this.length; + dest.negative = this.negative; +}; + +BN.prototype.clone = function clone() { + var r = new BN(null); + this.copy(r); + return r; +}; + +// Remove leading `0` from `this` +BN.prototype.strip = function strip() { + while (this.length > 1 && this.words[this.length - 1] === 0) + this.length--; + return this._normSign(); +}; + +BN.prototype._normSign = function _normSign() { + // -0 = 0 + if (this.length === 1 && this.words[0] === 0) + this.negative = 0; + return this; +}; + +var zeros = [ + '', + '0', + '00', + '000', + '0000', + '00000', + '000000', + '0000000', + '00000000', + '000000000', + '0000000000', + '00000000000', + '000000000000', + '0000000000000', + '00000000000000', + '000000000000000', + '0000000000000000', + '00000000000000000', + '000000000000000000', + '0000000000000000000', + '00000000000000000000', + '000000000000000000000', + '0000000000000000000000', + '00000000000000000000000', + '000000000000000000000000', + '0000000000000000000000000' +]; + +var groupSizes = [ + 0, 0, + 25, 16, 12, 11, 10, 9, 8, + 8, 7, 7, 7, 7, 6, 6, + 6, 6, 6, 6, 6, 5, 5, + 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 5, 5 +]; + +var groupBases = [ + 0, 0, + 33554432, 43046721, 16777216, 48828125, 60466176, 40353607, 16777216, + 43046721, 10000000, 19487171, 35831808, 62748517, 7529536, 11390625, + 16777216, 24137569, 34012224, 47045881, 64000000, 4084101, 5153632, + 6436343, 7962624, 9765625, 11881376, 14348907, 17210368, 20511149, + 24300000, 28629151, 33554432, 39135393, 45435424, 52521875, 60466176 +]; + +BN.prototype.toString = function toString(base, padding) { + base = base || 10; + var padding = padding | 0 || 1; + if (base === 16 || base === 'hex') { + var out = ''; + var off = 0; + var carry = 0; + for (var i = 0; i < this.length; i++) { + var w = this.words[i]; + var word = (((w << off) | carry) & 0xffffff).toString(16); + carry = (w >>> (24 - off)) & 0xffffff; + if (carry !== 0 || i !== this.length - 1) + out = zeros[6 - word.length] + word + out; + else + out = word + out; + off += 2; + if (off >= 26) { + off -= 26; + i--; + } + } + if (carry !== 0) + out = carry.toString(16) + out; + while (out.length % padding !== 0) + out = '0' + out; + if (this.negative !== 0) + out = '-' + out; + return out; + } else if (base === (base | 0) && base >= 2 && base <= 36) { + var groupSize = groupSizes[base]; + var groupBase = groupBases[base]; + var out = ''; + var c = this.clone(); + c.negative = 0; + while (c.cmpn(0) !== 0) { + var r = c.modn(groupBase).toString(base); + c = c.idivn(groupBase); + + if (c.cmpn(0) !== 0) + out = zeros[groupSize - r.length] + r + out; + else + out = r + out; + } + if (this.cmpn(0) === 0) + out = '0' + out; + while (out.length % padding !== 0) + out = '0' + out; + if (this.negative !== 0) + out = '-' + out; + return out; + } else { + throw 'Base should be between 2 and 36'; + } +}; + +BN.prototype.toJSON = function toJSON() { + return this.toString(16); +}; + +BN.prototype.toArray = function toArray(endian, length) { + this.strip(); + var littleEndian = endian === 'le'; + var res = new Array(this.byteLength()); + res[0] = 0; + + var q = this.clone(); + if (!littleEndian) { + // Assume big-endian + for (var i = 0; q.cmpn(0) !== 0; i++) { + var b = q.andln(0xff); + q.iushrn(8); + + res[res.length - i - 1] = b; + } + } else { + for (var i = 0; q.cmpn(0) !== 0; i++) { + var b = q.andln(0xff); + q.iushrn(8); + + res[i] = b; + } + } + + if (length) { + while (res.length < length) { + if (littleEndian) + res.push(0); + else + res.unshift(0); + } + } + + return res; +}; + +if (Math.clz32) { + BN.prototype._countBits = function _countBits(w) { + return 32 - Math.clz32(w); + }; +} else { + BN.prototype._countBits = function _countBits(w) { + var t = w; + var r = 0; + if (t >= 0x1000) { + r += 13; + t >>>= 13; + } + if (t >= 0x40) { + r += 7; + t >>>= 7; + } + if (t >= 0x8) { + r += 4; + t >>>= 4; + } + if (t >= 0x02) { + r += 2; + t >>>= 2; + } + return r + t; + }; +} + +// Return number of used bits in a BN +BN.prototype.bitLength = function bitLength() { + var hi = 0; + var w = this.words[this.length - 1]; + var hi = this._countBits(w); + return (this.length - 1) * 26 + hi; +}; + +BN.prototype.byteLength = function byteLength() { + return Math.ceil(this.bitLength() / 8); +}; + +// Return negative clone of `this` +BN.prototype.neg = function neg() { + if (this.cmpn(0) === 0) + return this.clone(); + + var r = this.clone(); + r.negative = this.negative ^ 1; + return r; +}; + +BN.prototype.ineg = function ineg() { + this.negative ^= 1; + return this; +}; + +// Or `num` with `this` in-place +BN.prototype.iuor = function iuor(num) { + while (this.length < num.length) + this.words[this.length++] = 0; + + for (var i = 0; i < num.length; i++) + this.words[i] = this.words[i] | num.words[i]; + + return this.strip(); +}; + +BN.prototype.ior = function ior(num) { + //assert((this.negative | num.negative) === 0); + return this.iuor(num); +}; + + +// Or `num` with `this` +BN.prototype.or = function or(num) { + if (this.length > num.length) + return this.clone().ior(num); + else + return num.clone().ior(this); +}; + +BN.prototype.uor = function uor(num) { + if (this.length > num.length) + return this.clone().iuor(num); + else + return num.clone().iuor(this); +}; + + +// And `num` with `this` in-place +BN.prototype.iuand = function iuand(num) { + // b = min-length(num, this) + var b; + if (this.length > num.length) + b = num; + else + b = this; + + for (var i = 0; i < b.length; i++) + this.words[i] = this.words[i] & num.words[i]; + + this.length = b.length; + + return this.strip(); +}; + +BN.prototype.iand = function iand(num) { + //assert((this.negative | num.negative) === 0); + return this.iuand(num); +}; + + +// And `num` with `this` +BN.prototype.and = function and(num) { + if (this.length > num.length) + return this.clone().iand(num); + else + return num.clone().iand(this); +}; + +BN.prototype.uand = function uand(num) { + if (this.length > num.length) + return this.clone().iuand(num); + else + return num.clone().iuand(this); +}; + + +// Xor `num` with `this` in-place +BN.prototype.iuxor = function iuxor(num) { + // a.length > b.length + var a; + var b; + if (this.length > num.length) { + a = this; + b = num; + } else { + a = num; + b = this; + } + + for (var i = 0; i < b.length; i++) + this.words[i] = a.words[i] ^ b.words[i]; + + if (this !== a) + for (; i < a.length; i++) + this.words[i] = a.words[i]; + + this.length = a.length; + + return this.strip(); +}; + +BN.prototype.ixor = function ixor(num) { + //assert((this.negative | num.negative) === 0); + return this.iuxor(num); +}; + + +// Xor `num` with `this` +BN.prototype.xor = function xor(num) { + if (this.length > num.length) + return this.clone().ixor(num); + else + return num.clone().ixor(this); +}; + +BN.prototype.uxor = function uxor(num) { + if (this.length > num.length) + return this.clone().iuxor(num); + else + return num.clone().iuxor(this); +}; + + +// Add `num` to `this` in-place +BN.prototype.iadd = function iadd(num) { + // negative + positive + if (this.negative !== 0 && num.negative === 0) { + this.negative = 0; + var r = this.isub(num); + this.negative ^= 1; + return this._normSign(); + + // positive + negative + } else if (this.negative === 0 && num.negative !== 0) { + num.negative = 0; + var r = this.isub(num); + num.negative = 1; + return r._normSign(); + } + + // a.length > b.length + var a; + var b; + if (this.length > num.length) { + a = this; + b = num; + } else { + a = num; + b = this; + } + + var carry = 0; + for (var i = 0; i < b.length; i++) { + var r = (a.words[i] | 0) + (b.words[i] | 0) + carry; + this.words[i] = r & 0x3ffffff; + carry = r >>> 26; + } + for (; carry !== 0 && i < a.length; i++) { + var r = (a.words[i] | 0) + carry; + this.words[i] = r & 0x3ffffff; + carry = r >>> 26; + } + + this.length = a.length; + if (carry !== 0) { + this.words[this.length] = carry; + this.length++; + // Copy the rest of the words + } else if (a !== this) { + for (; i < a.length; i++) + this.words[i] = a.words[i]; + } + + return this; +}; + +// Add `num` to `this` +BN.prototype.add = function add(num) { + if (num.negative !== 0 && this.negative === 0) { + num.negative = 0; + var res = this.sub(num); + num.negative ^= 1; + return res; + } else if (num.negative === 0 && this.negative !== 0) { + this.negative = 0; + var res = num.sub(this); + this.negative = 1; + return res; + } + + if (this.length > num.length) + return this.clone().iadd(num); + else + return num.clone().iadd(this); +}; + +// Subtract `num` from `this` in-place +BN.prototype.isub = function isub(num) { + // this - (-num) = this + num + if (num.negative !== 0) { + num.negative = 0; + var r = this.iadd(num); + num.negative = 1; + return r._normSign(); + + // -this - num = -(this + num) + } else if (this.negative !== 0) { + this.negative = 0; + this.iadd(num); + this.negative = 1; + return this._normSign(); + } + + // At this point both numbers are positive + var cmp = this.cmp(num); + + // Optimization - zeroify + if (cmp === 0) { + this.negative = 0; + this.length = 1; + this.words[0] = 0; + return this; + } + + // a > b + var a; + var b; + if (cmp > 0) { + a = this; + b = num; + } else { + a = num; + b = this; + } + + var carry = 0; + for (var i = 0; i < b.length; i++) { + var r = (a.words[i] | 0) - (b.words[i] | 0) + carry; + carry = r >> 26; + this.words[i] = r & 0x3ffffff; + } + for (; carry !== 0 && i < a.length; i++) { + var r = (a.words[i] | 0) + carry; + carry = r >> 26; + this.words[i] = r & 0x3ffffff; + } + + // Copy rest of the words + if (carry === 0 && i < a.length && a !== this) + for (; i < a.length; i++) + this.words[i] = a.words[i]; + this.length = Math.max(this.length, i); + + if (a !== this) + this.negative = 1; + + return this.strip(); +}; + +// Subtract `num` from `this` +BN.prototype.sub = function sub(num) { + return this.clone().isub(num); +}; + +function smallMulTo(self, num, out) { + out.negative = num.negative ^ self.negative; + var len = (self.length + num.length) | 0; + out.length = len; + len = (len - 1) | 0; + + // Peel one iteration (compiler can't do it, because of code complexity) + var a = self.words[0] | 0; + var b = num.words[0] | 0; + var r = a * b; + + var lo = r & 0x3ffffff; + var carry = (r / 0x4000000) | 0; + out.words[0] = lo; + + for (var k = 1; k < len; k++) { + // Sum all words with the same `i + j = k` and accumulate `ncarry`, + // note that ncarry could be >= 0x3ffffff + var ncarry = carry >>> 26; + var rword = carry & 0x3ffffff; + var maxJ = Math.min(k, num.length - 1); + for (var j = Math.max(0, k - self.length + 1); j <= maxJ; j++) { + var i = (k - j) | 0; + var a = self.words[i] | 0; + var b = num.words[j] | 0; + var r = a * b; + + var lo = r & 0x3ffffff; + ncarry = (ncarry + ((r / 0x4000000) | 0)) | 0; + lo = (lo + rword) | 0; + rword = lo & 0x3ffffff; + ncarry = (ncarry + (lo >>> 26)) | 0; + } + out.words[k] = rword | 0; + carry = ncarry | 0; + } + if (carry !== 0) { + out.words[k] = carry | 0; + } else { + out.length--; + } + + return out.strip(); +} + +function bigMulTo(self, num, out) { + out.negative = num.negative ^ self.negative; + out.length = self.length + num.length; + + var carry = 0; + var hncarry = 0; + for (var k = 0; k < out.length - 1; k++) { + // Sum all words with the same `i + j = k` and accumulate `ncarry`, + // note that ncarry could be >= 0x3ffffff + var ncarry = hncarry; + hncarry = 0; + var rword = carry & 0x3ffffff; + var maxJ = Math.min(k, num.length - 1); + for (var j = Math.max(0, k - self.length + 1); j <= maxJ; j++) { + var i = k - j; + var a = self.words[i] | 0; + var b = num.words[j] | 0; + var r = a * b; + + var lo = r & 0x3ffffff; + ncarry = (ncarry + ((r / 0x4000000) | 0)) | 0; + lo = (lo + rword) | 0; + rword = lo & 0x3ffffff; + ncarry = (ncarry + (lo >>> 26)) | 0; + + hncarry += ncarry >>> 26; + ncarry &= 0x3ffffff; + } + out.words[k] = rword; + carry = ncarry; + ncarry = hncarry; + } + if (carry !== 0) { + out.words[k] = carry; + } else { + out.length--; + } + + return out.strip(); +} + +BN.prototype.mulTo = function mulTo(num, out) { + var res; + if (this.length + num.length < 63) + res = smallMulTo(this, num, out); + else + res = bigMulTo(this, num, out); + return res; +}; + +// Multiply `this` by `num` +BN.prototype.mul = function mul(num) { + var out = new BN(null); + out.words = new Array(this.length + num.length); + return this.mulTo(num, out); +}; + +// In-place Multiplication +BN.prototype.imul = function imul(num) { + if (this.cmpn(0) === 0 || num.cmpn(0) === 0) { + this.words[0] = 0; + this.length = 1; + return this; + } + + var tlen = this.length; + var nlen = num.length; + + this.negative = num.negative ^ this.negative; + this.length = this.length + num.length; + this.words[this.length - 1] = 0; + + for (var k = this.length - 2; k >= 0; k--) { + // Sum all words with the same `i + j = k` and accumulate `carry`, + // note that carry could be >= 0x3ffffff + var carry = 0; + var rword = 0; + var maxJ = Math.min(k, nlen - 1); + for (var j = Math.max(0, k - tlen + 1); j <= maxJ; j++) { + var i = k - j; + var a = this.words[i] | 0; + var b = num.words[j] | 0; + var r = a * b; + + var lo = r & 0x3ffffff; + carry += (r / 0x4000000) | 0; + lo += rword; + rword = lo & 0x3ffffff; + carry += lo >>> 26; + } + this.words[k] = rword; + this.words[k + 1] += carry; + carry = 0; + } + + // Propagate overflows + var carry = 0; + for (var i = 1; i < this.length; i++) { + var w = (this.words[i] | 0) + carry; + this.words[i] = w & 0x3ffffff; + carry = w >>> 26; + } + + return this.strip(); +}; + +BN.prototype.imuln = function imuln(num) { + // Carry + var carry = 0; + for (var i = 0; i < this.length; i++) { + var w = (this.words[i] | 0) * num; + var lo = (w & 0x3ffffff) + (carry & 0x3ffffff); + carry >>= 26; + carry += (w / 0x4000000) | 0; + // NOTE: lo is 27bit maximum + carry += lo >>> 26; + this.words[i] = lo & 0x3ffffff; + } + + if (carry !== 0) { + this.words[i] = carry; + this.length++; + } + + return this; +}; + +BN.prototype.muln = function muln(num) { + return this.clone().imuln(num); +}; + +// `this` * `this` +BN.prototype.sqr = function sqr() { + return this.mul(this); +}; + +// `this` * `this` in-place +BN.prototype.isqr = function isqr() { + return this.mul(this); +}; + +// Shift-left in-place +BN.prototype.iushln = function iushln(bits) { + var r = bits % 26; + var s = (bits - r) / 26; + var carryMask = (0x3ffffff >>> (26 - r)) << (26 - r); + + if (r !== 0) { + var carry = 0; + for (var i = 0; i < this.length; i++) { + var newCarry = this.words[i] & carryMask; + var c = ((this.words[i] | 0) - newCarry) << r; + this.words[i] = c | carry; + carry = newCarry >>> (26 - r); + } + if (carry) { + this.words[i] = carry; + this.length++; + } + } + + if (s !== 0) { + for (var i = this.length - 1; i >= 0; i--) + this.words[i + s] = this.words[i]; + for (var i = 0; i < s; i++) + this.words[i] = 0; + this.length += s; + } + + return this.strip(); +}; + +BN.prototype.ishln = function ishln(bits) { + return this.iushln(bits); +}; + +// Shift-right in-place +BN.prototype.iushrn = function iushrn(bits, hint, extended) { + var h; + if (hint) + h = (hint - (hint % 26)) / 26; + else + h = 0; + + var r = bits % 26; + var s = Math.min((bits - r) / 26, this.length); + var mask = 0x3ffffff ^ ((0x3ffffff >>> r) << r); + var maskedWords = extended; + + h -= s; + h = Math.max(0, h); + + // Extended mode, copy masked part + if (maskedWords) { + for (var i = 0; i < s; i++) + maskedWords.words[i] = this.words[i]; + maskedWords.length = s; + } + + if (s === 0) { + // No-op, we should not move anything at all + } else if (this.length > s) { + this.length -= s; + for (var i = 0; i < this.length; i++) + this.words[i] = this.words[i + s]; + } else { + this.words[0] = 0; + this.length = 1; + } + + var carry = 0; + for (var i = this.length - 1; i >= 0 && (carry !== 0 || i >= h); i--) { + var word = this.words[i] | 0; + this.words[i] = (carry << (26 - r)) | (word >>> r); + carry = word & mask; + } + + // Push carried bits as a mask + if (maskedWords && carry !== 0) + maskedWords.words[maskedWords.length++] = carry; + + if (this.length === 0) { + this.words[0] = 0; + this.length = 1; + } + + this.strip(); + + return this; +}; + +BN.prototype.ishrn = function ishrn(bits, hint, extended) { + return this.iushrn(bits, hint, extended); +}; + +// Shift-left +BN.prototype.shln = function shln(bits) { + var x = this.clone(); + var neg = x.negative; + x.negative = false; + x.ishln(bits); + x.negative = neg; + return x; +}; + +BN.prototype.ushln = function ushln(bits) { + return this.clone().iushln(bits); +}; + +// Shift-right +BN.prototype.shrn = function shrn(bits) { + var x = this.clone(); + if(x.negative) { + x.negative = false; + x.ishrn(bits); + x.negative = true; + return x.isubn(1); + } else { + return x.ishrn(bits); + } +}; + +BN.prototype.ushrn = function ushrn(bits) { + return this.clone().iushrn(bits); +}; + +// Test if n bit is set +BN.prototype.testn = function testn(bit) { + var r = bit % 26; + var s = (bit - r) / 26; + var q = 1 << r; + + // Fast case: bit is much higher than all existing words + if (this.length <= s) { + return false; + } + + // Check bit and return + var w = this.words[s]; + + return !!(w & q); +}; + +// Add plain number `num` to `this` +BN.prototype.iaddn = function iaddn(num) { + if (num < 0) + return this.isubn(-num); + + // Possible sign change + if (this.negative !== 0) { + if (this.length === 1 && (this.words[0] | 0) < num) { + this.words[0] = num - (this.words[0] | 0); + this.negative = 0; + return this; + } + + this.negative = 0; + this.isubn(num); + this.negative = 1; + return this; + } + + // Add without checks + return this._iaddn(num); +}; + +BN.prototype._iaddn = function _iaddn(num) { + this.words[0] += num; + + // Carry + for (var i = 0; i < this.length && this.words[i] >= 0x4000000; i++) { + this.words[i] -= 0x4000000; + if (i === this.length - 1) + this.words[i + 1] = 1; + else + this.words[i + 1]++; + } + this.length = Math.max(this.length, i + 1); + + return this; +}; + +// Subtract plain number `num` from `this` +BN.prototype.isubn = function isubn(num) { + if (num < 0) + return this.iaddn(-num); + + if (this.negative !== 0) { + this.negative = 0; + this.iaddn(num); + this.negative = 1; + return this; + } + + this.words[0] -= num; + + // Carry + for (var i = 0; i < this.length && this.words[i] < 0; i++) { + this.words[i] += 0x4000000; + this.words[i + 1] -= 1; + } + + return this.strip(); +}; + +BN.prototype.addn = function addn(num) { + return this.clone().iaddn(num); +}; + +BN.prototype.subn = function subn(num) { + return this.clone().isubn(num); +}; + +BN.prototype.iabs = function iabs() { + this.negative = 0; + + return this; +}; + +BN.prototype.abs = function abs() { + return this.clone().iabs(); +}; + +BN.prototype._ishlnsubmul = function _ishlnsubmul(num, mul, shift) { + // Bigger storage is needed + var len = num.length + shift; + var i; + if (this.words.length < len) { + var t = new Array(len); + for (var i = 0; i < this.length; i++) + t[i] = this.words[i]; + this.words = t; + } else { + i = this.length; + } + + // Zeroify rest + this.length = Math.max(this.length, len); + for (; i < this.length; i++) + this.words[i] = 0; + + var carry = 0; + for (var i = 0; i < num.length; i++) { + var w = (this.words[i + shift] | 0) + carry; + var right = (num.words[i] | 0) * mul; + w -= right & 0x3ffffff; + carry = (w >> 26) - ((right / 0x4000000) | 0); + this.words[i + shift] = w & 0x3ffffff; + } + for (; i < this.length - shift; i++) { + var w = (this.words[i + shift] | 0) + carry; + carry = w >> 26; + this.words[i + shift] = w & 0x3ffffff; + } + + if (carry === 0) + return this.strip(); + + carry = 0; + for (var i = 0; i < this.length; i++) { + var w = -(this.words[i] | 0) + carry; + carry = w >> 26; + this.words[i] = w & 0x3ffffff; + } + this.negative = 1; + + return this.strip(); +}; + +BN.prototype._wordDiv = function _wordDiv(num, mode) { + var shift = this.length - num.length; + + var a = this.clone(); + var b = num; + + // Normalize + var bhi = b.words[b.length - 1] | 0; + var bhiBits = this._countBits(bhi); + shift = 26 - bhiBits; + if (shift !== 0) { + b = b.ushln(shift); + a.iushln(shift); + bhi = b.words[b.length - 1] | 0; + } + + // Initialize quotient + var m = a.length - b.length; + var q; + + if (mode !== 'mod') { + q = new BN(null); + q.length = m + 1; + q.words = new Array(q.length); + for (var i = 0; i < q.length; i++) + q.words[i] = 0; + } + + var diff = a.clone()._ishlnsubmul(b, 1, m); + if (diff.negative === 0) { + a = diff; + if (q) + q.words[m] = 1; + } + + for (var j = m - 1; j >= 0; j--) { + var qj = (a.words[b.length + j] | 0) * 0x4000000 + + (a.words[b.length + j - 1] | 0); + + // NOTE: (qj / bhi) is (0x3ffffff * 0x4000000 + 0x3ffffff) / 0x2000000 max + // (0x7ffffff) + qj = Math.min((qj / bhi) | 0, 0x3ffffff); + + a._ishlnsubmul(b, qj, j); + while (a.negative !== 0) { + qj--; + a.negative = 0; + a._ishlnsubmul(b, 1, j); + if (a.cmpn(0) !== 0) + a.negative ^= 1; + } + if (q) + q.words[j] = qj; + } + if (q) + q.strip(); + a.strip(); + + // Denormalize + if (mode !== 'div' && shift !== 0) + a.iushrn(shift); + return { div: q ? q : null, mod: a }; +}; + +BN.prototype.divmod = function divmod(num, mode, positive) { + if (this.negative !== 0 && num.negative === 0) { + var res = this.neg().divmod(num, mode); + var div; + var mod; + if (mode !== 'mod') + div = res.div.neg(); + if (mode !== 'div') { + mod = res.mod.neg(); + if (positive && mod.neg) + mod = mod.add(num); + } + return { + div: div, + mod: mod + }; + } else if (this.negative === 0 && num.negative !== 0) { + var res = this.divmod(num.neg(), mode); + var div; + if (mode !== 'mod') + div = res.div.neg(); + return { div: div, mod: res.mod }; + } else if ((this.negative & num.negative) !== 0) { + var res = this.neg().divmod(num.neg(), mode); + var mod; + if (mode !== 'div') { + mod = res.mod.neg(); + if (positive && mod.neg) + mod = mod.isub(num); + } + return { + div: res.div, + mod: mod + }; + } + + // Both numbers are positive at this point + + // Strip both numbers to approximate shift value + if (num.length > this.length || this.cmp(num) < 0) + return { div: new BN(0), mod: this }; + + // Very short reduction + if (num.length === 1) { + if (mode === 'div') + return { div: this.divn(num.words[0]), mod: null }; + else if (mode === 'mod') + return { div: null, mod: new BN(this.modn(num.words[0])) }; + return { + div: this.divn(num.words[0]), + mod: new BN(this.modn(num.words[0])) + }; + } + + return this._wordDiv(num, mode); +}; + +// Find `this` / `num` +BN.prototype.div = function div(num) { + return this.divmod(num, 'div', false).div; +}; + +// Find `this` % `num` +BN.prototype.mod = function mod(num) { + return this.divmod(num, 'mod', false).mod; +}; + +BN.prototype.umod = function umod(num) { + return this.divmod(num, 'mod', true).mod; +}; + +// Find Round(`this` / `num`) +BN.prototype.divRound = function divRound(num) { + var dm = this.divmod(num); + + // Fast case - exact division + if (dm.mod.cmpn(0) === 0) + return dm.div; + + var mod = dm.div.negative !== 0 ? dm.mod.isub(num) : dm.mod; + + var half = num.ushrn(1); + var r2 = num.andln(1); + var cmp = mod.cmp(half); + + // Round down + if (cmp < 0 || r2 === 1 && cmp === 0) + return dm.div; + + // Round up + return dm.div.negative !== 0 ? dm.div.isubn(1) : dm.div.iaddn(1); +}; + +BN.prototype.modn = function modn(num) { + var p = (1 << 26) % num; + + var acc = 0; + for (var i = this.length - 1; i >= 0; i--) + acc = (p * acc + (this.words[i] | 0)) % num; + + return acc; +}; + +// In-place division by number +BN.prototype.idivn = function idivn(num) { + var carry = 0; + for (var i = this.length - 1; i >= 0; i--) { + var w = (this.words[i] | 0) + carry * 0x4000000; + this.words[i] = (w / num) | 0; + carry = w % num; + } + + return this.strip(); +}; + +BN.prototype.divn = function divn(num) { + return this.clone().idivn(num); +}; + +BN.prototype.isEven = function isEven() { + return (this.words[0] & 1) === 0; +}; + +BN.prototype.isOdd = function isOdd() { + return (this.words[0] & 1) === 1; +}; + +// And first word and num +BN.prototype.andln = function andln(num) { + return this.words[0] & num; +}; + +BN.prototype.cmpn = function cmpn(num) { + var negative = num < 0; + if (negative) + num = -num; + + if (this.negative !== 0 && !negative) + return -1; + else if (this.negative === 0 && negative) + return 1; + + num &= 0x3ffffff; + this.strip(); + + var res; + if (this.length > 1) { + res = 1; + } else { + var w = this.words[0] | 0; + res = w === num ? 0 : w < num ? -1 : 1; + } + if (this.negative !== 0) + res = -res; + return res; +}; + +// Compare two numbers and return: +// 1 - if `this` > `num` +// 0 - if `this` == `num` +// -1 - if `this` < `num` +BN.prototype.cmp = function cmp(num) { + if (this.negative !== 0 && num.negative === 0) + return -1; + else if (this.negative === 0 && num.negative !== 0) + return 1; + + var res = this.ucmp(num); + if (this.negative !== 0) + return -res; + else + return res; +}; + +// Unsigned comparison +BN.prototype.ucmp = function ucmp(num) { + // At this point both numbers have the same sign + if (this.length > num.length) + return 1; + else if (this.length < num.length) + return -1; + + var res = 0; + for (var i = this.length - 1; i >= 0; i--) { + var a = this.words[i] | 0; + var b = num.words[i] | 0; + + if (a === b) + continue; + if (a < b) + res = -1; + else if (a > b) + res = 1; + break; + } + return res; +}; +})(undefined, __bn); diff --git a/lib/floatdecode.js b/lib/floatdecode.js --- a/lib/floatdecode.js +++ b/lib/floatdecode.js @@ -6,7 +6,7 @@ function decodeFloat(x) { if(x === 0) { - return [0,1,0,0,0]; + return __decodedZeroF; } rts_scratchFloat[0] = x; var sign = x < 0 ? -1 : 1; @@ -17,14 +17,17 @@ } else { man |= (1 << 23); } - return [0, sign*man, exp]; + return {_:0, a:sign*man, b:exp}; } +var __decodedZero = {_:0,a:1,b:0,c:0,d:0}; +var __decodedZeroF = {_:0,a:1,b:0}; + function decodeDouble(x) { if(x === 0) { // GHC 7.10+ *really* doesn't like 0 to be represented as anything // but zeroes all the way. - return [0,1,0,0,0]; + return __decodedZero; } rts_scratchDouble[0] = x; var sign = x < 0 ? -1 : 1; @@ -36,5 +39,5 @@ } else { manHigh |= (1 << 20); } - return [0, sign, manHigh, manLow, exp]; + return {_:0, a:sign, b:manHigh, c:manLow, d:exp}; } diff --git a/lib/long.js b/lib/long.js new file mode 100644 --- /dev/null +++ b/lib/long.js @@ -0,0 +1,341 @@ +/** + * @license long.js (c) 2013 Daniel Wirtz + * Released under the Apache License, Version 2.0 + * see: https://github.com/dcodeIO/long.js for details + */ +function Long(low, high, unsigned) { + this.low = low | 0; + this.high = high | 0; + this.unsigned = !!unsigned; +} + +var INT_CACHE = {}; +var UINT_CACHE = {}; +function cacheable(x, u) { + return u ? 0 <= (x >>>= 0) && x < 256 : -128 <= (x |= 0) && x < 128; +} + +function __fromInt(value, unsigned) { + var obj, cachedObj, cache; + if (unsigned) { + if (cache = cacheable(value >>>= 0, true)) { + cachedObj = UINT_CACHE[value]; + if (cachedObj) + return cachedObj; + } + obj = new Long(value, (value | 0) < 0 ? -1 : 0, true); + if (cache) + UINT_CACHE[value] = obj; + return obj; + } else { + if (cache = cacheable(value |= 0, false)) { + cachedObj = INT_CACHE[value]; + if (cachedObj) + return cachedObj; + } + obj = new Long(value, value < 0 ? -1 : 0, false); + if (cache) + INT_CACHE[value] = obj; + return obj; + } +} + +function __fromNumber(value, unsigned) { + if (isNaN(value) || !isFinite(value)) + return unsigned ? UZERO : ZERO; + if (unsigned) { + if (value < 0) + return UZERO; + if (value >= TWO_PWR_64_DBL) + return MAX_UNSIGNED_VALUE; + } else { + if (value <= -TWO_PWR_63_DBL) + return MIN_VALUE; + if (value + 1 >= TWO_PWR_63_DBL) + return MAX_VALUE; + } + if (value < 0) + return __fromNumber(-value, unsigned).neg(); + return new Long((value % TWO_PWR_32_DBL) | 0, (value / TWO_PWR_32_DBL) | 0, unsigned); +} +var pow_dbl = Math.pow; +var TWO_PWR_16_DBL = 1 << 16; +var TWO_PWR_24_DBL = 1 << 24; +var TWO_PWR_32_DBL = TWO_PWR_16_DBL * TWO_PWR_16_DBL; +var TWO_PWR_64_DBL = TWO_PWR_32_DBL * TWO_PWR_32_DBL; +var TWO_PWR_63_DBL = TWO_PWR_64_DBL / 2; +var TWO_PWR_24 = __fromInt(TWO_PWR_24_DBL); +var ZERO = __fromInt(0); +Long.ZERO = ZERO; +var UZERO = __fromInt(0, true); +Long.UZERO = UZERO; +var ONE = __fromInt(1); +Long.ONE = ONE; +var UONE = __fromInt(1, true); +Long.UONE = UONE; +var NEG_ONE = __fromInt(-1); +Long.NEG_ONE = NEG_ONE; +var MAX_VALUE = new Long(0xFFFFFFFF|0, 0x7FFFFFFF|0, false); +Long.MAX_VALUE = MAX_VALUE; +var MAX_UNSIGNED_VALUE = new Long(0xFFFFFFFF|0, 0xFFFFFFFF|0, true); +Long.MAX_UNSIGNED_VALUE = MAX_UNSIGNED_VALUE; +var MIN_VALUE = new Long(0, 0x80000000|0, false); +Long.MIN_VALUE = MIN_VALUE; +var __lp = Long.prototype; +__lp.toInt = function() {return this.unsigned ? this.low >>> 0 : this.low;}; +__lp.toNumber = function() { + if (this.unsigned) + return ((this.high >>> 0) * TWO_PWR_32_DBL) + (this.low >>> 0); + return this.high * TWO_PWR_32_DBL + (this.low >>> 0); +}; +__lp.isZero = function() {return this.high === 0 && this.low === 0;}; +__lp.isNegative = function() {return !this.unsigned && this.high < 0;}; +__lp.isOdd = function() {return (this.low & 1) === 1;}; +__lp.eq = function(other) { + if (this.unsigned !== other.unsigned && (this.high >>> 31) === 1 && (other.high >>> 31) === 1) + return false; + return this.high === other.high && this.low === other.low; +}; +__lp.neq = function(other) {return !this.eq(other);}; +__lp.lt = function(other) {return this.comp(other) < 0;}; +__lp.lte = function(other) {return this.comp(other) <= 0;}; +__lp.gt = function(other) {return this.comp(other) > 0;}; +__lp.gte = function(other) {return this.comp(other) >= 0;}; +__lp.compare = function(other) { + if (this.eq(other)) + return 0; + var thisNeg = this.isNegative(), + otherNeg = other.isNegative(); + if (thisNeg && !otherNeg) + return -1; + if (!thisNeg && otherNeg) + return 1; + if (!this.unsigned) + return this.sub(other).isNegative() ? -1 : 1; + return (other.high >>> 0) > (this.high >>> 0) || (other.high === this.high && (other.low >>> 0) > (this.low >>> 0)) ? -1 : 1; +}; +__lp.comp = __lp.compare; +__lp.negate = function() { + if (!this.unsigned && this.eq(MIN_VALUE)) + return MIN_VALUE; + return this.not().add(ONE); +}; +__lp.neg = __lp.negate; +__lp.add = function(addend) { + var a48 = this.high >>> 16; + var a32 = this.high & 0xFFFF; + var a16 = this.low >>> 16; + var a00 = this.low & 0xFFFF; + + var b48 = addend.high >>> 16; + var b32 = addend.high & 0xFFFF; + var b16 = addend.low >>> 16; + var b00 = addend.low & 0xFFFF; + + var c48 = 0, c32 = 0, c16 = 0, c00 = 0; + c00 += a00 + b00; + c16 += c00 >>> 16; + c00 &= 0xFFFF; + c16 += a16 + b16; + c32 += c16 >>> 16; + c16 &= 0xFFFF; + c32 += a32 + b32; + c48 += c32 >>> 16; + c32 &= 0xFFFF; + c48 += a48 + b48; + c48 &= 0xFFFF; + return new Long((c16 << 16) | c00, (c48 << 16) | c32, this.unsigned); +}; +__lp.subtract = function(subtrahend) {return this.add(subtrahend.neg());}; +__lp.sub = __lp.subtract; +__lp.multiply = function(multiplier) { + if (this.isZero()) + return ZERO; + if (multiplier.isZero()) + return ZERO; + if (this.eq(MIN_VALUE)) + return multiplier.isOdd() ? MIN_VALUE : ZERO; + if (multiplier.eq(MIN_VALUE)) + return this.isOdd() ? MIN_VALUE : ZERO; + + if (this.isNegative()) { + if (multiplier.isNegative()) + return this.neg().mul(multiplier.neg()); + else + return this.neg().mul(multiplier).neg(); + } else if (multiplier.isNegative()) + return this.mul(multiplier.neg()).neg(); + + if (this.lt(TWO_PWR_24) && multiplier.lt(TWO_PWR_24)) + return __fromNumber(this.toNumber() * multiplier.toNumber(), this.unsigned); + + var a48 = this.high >>> 16; + var a32 = this.high & 0xFFFF; + var a16 = this.low >>> 16; + var a00 = this.low & 0xFFFF; + + var b48 = multiplier.high >>> 16; + var b32 = multiplier.high & 0xFFFF; + var b16 = multiplier.low >>> 16; + var b00 = multiplier.low & 0xFFFF; + + var c48 = 0, c32 = 0, c16 = 0, c00 = 0; + c00 += a00 * b00; + c16 += c00 >>> 16; + c00 &= 0xFFFF; + c16 += a16 * b00; + c32 += c16 >>> 16; + c16 &= 0xFFFF; + c16 += a00 * b16; + c32 += c16 >>> 16; + c16 &= 0xFFFF; + c32 += a32 * b00; + c48 += c32 >>> 16; + c32 &= 0xFFFF; + c32 += a16 * b16; + c48 += c32 >>> 16; + c32 &= 0xFFFF; + c32 += a00 * b32; + c48 += c32 >>> 16; + c32 &= 0xFFFF; + c48 += a48 * b00 + a32 * b16 + a16 * b32 + a00 * b48; + c48 &= 0xFFFF; + return new Long((c16 << 16) | c00, (c48 << 16) | c32, this.unsigned); +}; +__lp.mul = __lp.multiply; +__lp.divide = function(divisor) { + if (divisor.isZero()) + throw Error('division by zero'); + if (this.isZero()) + return this.unsigned ? UZERO : ZERO; + var approx, rem, res; + if (this.eq(MIN_VALUE)) { + if (divisor.eq(ONE) || divisor.eq(NEG_ONE)) + return MIN_VALUE; + else if (divisor.eq(MIN_VALUE)) + return ONE; + else { + var halfThis = this.shr(1); + approx = halfThis.div(divisor).shl(1); + if (approx.eq(ZERO)) { + return divisor.isNegative() ? ONE : NEG_ONE; + } else { + rem = this.sub(divisor.mul(approx)); + res = approx.add(rem.div(divisor)); + return res; + } + } + } else if (divisor.eq(MIN_VALUE)) + return this.unsigned ? UZERO : ZERO; + if (this.isNegative()) { + if (divisor.isNegative()) + return this.neg().div(divisor.neg()); + return this.neg().div(divisor).neg(); + } else if (divisor.isNegative()) + return this.div(divisor.neg()).neg(); + + res = ZERO; + rem = this; + while (rem.gte(divisor)) { + approx = Math.max(1, Math.floor(rem.toNumber() / divisor.toNumber())); + var log2 = Math.ceil(Math.log(approx) / Math.LN2), + delta = (log2 <= 48) ? 1 : pow_dbl(2, log2 - 48), + approxRes = __fromNumber(approx), + approxRem = approxRes.mul(divisor); + while (approxRem.isNegative() || approxRem.gt(rem)) { + approx -= delta; + approxRes = __fromNumber(approx, this.unsigned); + approxRem = approxRes.mul(divisor); + } + if (approxRes.isZero()) + approxRes = ONE; + + res = res.add(approxRes); + rem = rem.sub(approxRem); + } + return res; +}; +__lp.div = __lp.divide; +__lp.modulo = function(divisor) {return this.sub(this.div(divisor).mul(divisor));}; +__lp.mod = __lp.modulo; +__lp.not = function not() {return new Long(~this.low, ~this.high, this.unsigned);}; +__lp.and = function(other) {return new Long(this.low & other.low, this.high & other.high, this.unsigned);}; +__lp.or = function(other) {return new Long(this.low | other.low, this.high | other.high, this.unsigned);}; +__lp.xor = function(other) {return new Long(this.low ^ other.low, this.high ^ other.high, this.unsigned);}; + +__lp.shl = function(numBits) { + if ((numBits &= 63) === 0) + return this; + else if (numBits < 32) + return new Long(this.low << numBits, (this.high << numBits) | (this.low >>> (32 - numBits)), this.unsigned); + else + return new Long(0, this.low << (numBits - 32), this.unsigned); +}; + +__lp.shr = function(numBits) { + if ((numBits &= 63) === 0) + return this; + else if (numBits < 32) + return new Long((this.low >>> numBits) | (this.high << (32 - numBits)), this.high >> numBits, this.unsigned); + else + return new Long(this.high >> (numBits - 32), this.high >= 0 ? 0 : -1, this.unsigned); +}; + +__lp.shru = function(numBits) { + numBits &= 63; + if (numBits === 0) + return this; + else { + var high = this.high; + if (numBits < 32) { + var low = this.low; + return new Long((low >>> numBits) | (high << (32 - numBits)), high >>> numBits, this.unsigned); + } else if (numBits === 32) + return new Long(high, 0, this.unsigned); + else + return new Long(high >>> (numBits - 32), 0, this.unsigned); + } +}; + +__lp.toSigned = function() {return this.unsigned ? new Long(this.low, this.high, false) : this;}; +__lp.toUnsigned = function() {return this.unsigned ? this : new Long(this.low, this.high, true);}; + +// Int64 +function hs_eqInt64(x, y) {return x.eq(y);} +function hs_neInt64(x, y) {return x.neq(y);} +function hs_ltInt64(x, y) {return x.lt(y);} +function hs_leInt64(x, y) {return x.lte(y);} +function hs_gtInt64(x, y) {return x.gt(y);} +function hs_geInt64(x, y) {return x.gte(y);} +function hs_quotInt64(x, y) {return x.div(y);} +function hs_remInt64(x, y) {return x.modulo(y);} +function hs_plusInt64(x, y) {return x.add(y);} +function hs_minusInt64(x, y) {return x.subtract(y);} +function hs_timesInt64(x, y) {return x.multiply(y);} +function hs_negateInt64(x) {return x.negate();} +function hs_uncheckedIShiftL64(x, bits) {return x.shl(bits);} +function hs_uncheckedIShiftRA64(x, bits) {return x.shr(bits);} +function hs_uncheckedIShiftRL64(x, bits) {return x.shru(bits);} +function hs_int64ToInt(x) {return x.toInt();} +var hs_intToInt64 = __fromInt; + +// Word64 +function hs_wordToWord64(x) {return __fromInt(x, true);} +function hs_word64ToWord(x) {return x.toInt(x);} +function hs_mkWord64(low, high) {return new Long(low,high,true);} +function hs_and64(a,b) {return a.and(b);}; +function hs_or64(a,b) {return a.or(b);}; +function hs_xor64(a,b) {return a.xor(b);}; +function hs_not64(x) {return x.not();} +var hs_eqWord64 = hs_eqInt64; +var hs_neWord64 = hs_neInt64; +var hs_ltWord64 = hs_ltInt64; +var hs_leWord64 = hs_leInt64; +var hs_gtWord64 = hs_gtInt64; +var hs_geWord64 = hs_geInt64; +var hs_quotWord64 = hs_quotInt64; +var hs_remWord64 = hs_remInt64; +var hs_uncheckedShiftL64 = hs_uncheckedIShiftL64; +var hs_uncheckedShiftRL64 = hs_uncheckedIShiftRL64; +function hs_int64ToWord64(x) {return x.toUnsigned();} +function hs_word64ToInt64(x) {return x.toSigned();} diff --git a/lib/rts.js b/lib/rts.js --- a/lib/rts.js +++ b/lib/rts.js @@ -1,6 +1,15 @@ // This object will hold all exports. var Haste = {}; +/* Constructor functions for small ADTs. */ +function T0(t){this._=t;} +function T1(t,a){this._=t;this.a=a;} +function T2(t,a,b){this._=t;this.a=a;this.b=b;} +function T3(t,a,b,c){this._=t;this.a=a;this.b=b;this.c=c;} +function T4(t,a,b,c,d){this._=t;this.a=a;this.b=b;this.c=c;this.d=d;} +function T5(t,a,b,c,d,e){this._=t;this.a=a;this.b=b;this.c=c;this.d=d;this.e=e;} +function T6(t,a,b,c,d,e,f){this._=t;this.a=a;this.b=b;this.c=c;this.d=d;this.e=e;this.f=f;} + /* Thunk Creates a thunk representing the given closure. If the non-updatable flag is undefined, the thunk is updatable. @@ -27,12 +36,19 @@ this.arity = f.length - args.length; } +// "Zero" object; used to avoid creating a whole bunch of new objects +// in the extremely common case of a nil-like data constructor. +var __Z = new T0(0); + // Special object used for blackholing. var __blackhole = {}; // Used to indicate that an object is updatable. var __updatable = {}; +// Indicates that a closure-creating tail loop isn't done. +var __continue = {}; + /* Generic apply. Applies a function *or* a partial application object to a list of arguments. See https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/HaskellExecution/FunctionCalls @@ -41,25 +57,8 @@ function A(f, args) { while(true) { f = E(f); - if(f instanceof F) { - f = E(B(f)); - } - if(f instanceof PAP) { - // f is a partial application - if(args.length == f.arity) { - // Saturated application - return f.f.apply(null, f.args.concat(args)); - } else if(args.length < f.arity) { - // Application is still unsaturated - return new PAP(f.f, f.args.concat(args)); - } else { - // Application is oversaturated; - var f2 = f.f.apply(null, f.args.concat(args.slice(0, f.arity))); - args = args.slice(f.arity); - f = B(f2); - } - } else if(f instanceof Function) { - if(args.length == f.length) { + if(f instanceof Function) { + if(args.length === f.length) { return f.apply(null, args); } else if(args.length < f.length) { return new PAP(f, args); @@ -68,12 +67,74 @@ args = args.slice(f.length); f = B(f2); } + } else if(f instanceof PAP) { + if(args.length === f.arity) { + return f.f.apply(null, f.args.concat(args)); + } else if(args.length < f.arity) { + return new PAP(f.f, f.args.concat(args)); + } else { + var f2 = f.f.apply(null, f.args.concat(args.slice(0, f.arity))); + args = args.slice(f.arity); + f = B(f2); + } } else { return f; } } } +function A1(f, x) { + f = E(f); + if(f instanceof Function) { + return f.length === 1 ? f(x) : new PAP(f, [x]); + } else if(f instanceof PAP) { + return f.arity === 1 ? f.f.apply(null, f.args.concat([x])) + : new PAP(f.f, f.args.concat([x])); + } else { + return f; + } +} + +function A2(f, x, y) { + f = E(f); + if(f instanceof Function) { + switch(f.length) { + case 2: return f(x, y); + case 1: return A1(B(f(x)), y); + default: return new PAP(f, [x,y]); + } + } else if(f instanceof PAP) { + switch(f.arity) { + case 2: return f.f.apply(null, f.args.concat([x,y])); + case 1: return A1(B(f.f.apply(null, f.args.concat([x]))), y); + default: return new PAP(f.f, f.args.concat([x,y])); + } + } else { + return f; + } +} + +function A3(f, x, y, z) { + f = E(f); + if(f instanceof Function) { + switch(f.length) { + case 3: return f(x, y, z); + case 2: return A1(B(f(x, y)), z); + case 1: return A2(B(f(x)), y, z); + default: return new PAP(f, [x,y,z]); + } + } else if(f instanceof PAP) { + switch(f.arity) { + case 3: return f.f.apply(null, f.args.concat([x,y,z])); + case 2: return A1(B(f.f.apply(null, f.args.concat([x,y]))), z); + case 1: return A2(B(f.f.apply(null, f.args.concat([x]))), y, z); + default: return new PAP(f.f, f.args.concat([x,y,z])); + } + } else { + return f; + } +} + /* Eval Evaluate the given thunk t into head normal form. If the "thunk" we get isn't actually a thunk, just return it. @@ -89,21 +150,31 @@ return t.f(); } } - return t.x; + if(t.x === __updatable) { + throw 'Infinite loop!'; + } else { + return t.x; + } } else { return t; } } +/* Tail call chain counter. */ +var C = 0, Cs = []; + /* Bounce Bounce on a trampoline for as long as we get a function back. */ function B(f) { + Cs.push(C); while(f instanceof F) { var fun = f.f; f.f = __blackhole; + C = 0; f = fun(); } + C = Cs.pop(); return f; } @@ -130,7 +201,7 @@ } function quotRemI(a, b) { - return [0, (a-a%b)/b, a%b]; + return {_:0, a:(a-a%b)/b, b:a%b}; } // 32 bit integer multiplication, with correct overflow behavior @@ -150,12 +221,12 @@ function addC(a, b) { var x = a+b; - return [0, x & 0xffffffff, x > 0x7fffffff]; + return {_:0, a:x & 0xffffffff, b:x > 0x7fffffff}; } function subC(a, b) { var x = a-b; - return [0, x & 0xffffffff, x < -2147483648]; + return {_:0, a:x & 0xffffffff, b:x < -2147483648}; } function sinh (arg) { @@ -185,7 +256,7 @@ /* unpackCString# NOTE: update constructor tags if the code generator starts munging them. */ -function unCStr(str) {return unAppCStr(str, [0]);} +function unCStr(str) {return unAppCStr(str, __Z);} function unFoldrCStr(str, f, z) { var acc = z; @@ -200,9 +271,9 @@ if(i >= str.length) { return E(chrs); } else { - return [1,str.charCodeAt(i),new T(function() { + return {_:1,a:str.charCodeAt(i),b:new T(function() { return unAppCStr(str,chrs,i+1); - })]; + })}; } } @@ -214,8 +285,8 @@ function toJSStr(hsstr) { var s = ''; - for(var str = E(hsstr); str[0] == 1; str = E(str[2])) { - s += String.fromCharCode(E(str[1])); + for(var str = E(hsstr); str._ == 1; str = E(str.b)) { + s += String.fromCharCode(E(str.a)); } return s; } @@ -238,8 +309,8 @@ // atomicModifyMutVar function mMV(mv, f) { var x = B(A(f, [mv.x])); - mv.x = x[1]; - return x[2]; + mv.x = x.a; + return x.b; } function localeEncoding() { @@ -291,8 +362,8 @@ However, dataToTag should use 0, 1, 2, etc. Also, booleans might be unboxed. */ function dataToTag(x) { - if(x instanceof Array) { - return x[0]; + if(x instanceof Object) { + return x._; } else { return x; } @@ -316,7 +387,7 @@ } function popCnt64(i) { - return popCnt(I_getBits(i,0)) + popCnt(I_getBits(i,1)); + return popCnt(i.low) + popCnt(i.high); } function popCnt(i) { diff --git a/lib/stdlib.js b/lib/stdlib.js --- a/lib/stdlib.js +++ b/lib/stdlib.js @@ -36,10 +36,10 @@ function jsCat(strs, sep) { var arr = []; strs = E(strs); - while(strs[0]) { + while(strs._) { strs = E(strs); - arr.push(E(strs[1])); - strs = E(strs[2]); + arr.push(E(strs.a)); + strs = E(strs.b); } return arr.join(sep); } @@ -55,24 +55,24 @@ var js = JSON.parse(str); var hs = toHS(js); } catch(_) { - return [0]; + return __Z; } - return [1,hs]; + return {_:1,a:hs}; } function toHS(obj) { switch(typeof obj) { case 'number': - return [0, jsRead(obj)]; + return {_:0, a:jsRead(obj)}; case 'string': - return [1, obj]; + return {_:1, a:obj}; case 'boolean': - return [2, obj]; // Booleans are special wrt constructor tags! + return {_:2, a:obj}; // Booleans are special wrt constructor tags! case 'object': if(obj instanceof Array) { - return [3, arr2lst_json(obj, 0)]; + return {_:3, a:arr2lst_json(obj, 0)}; } else if (obj == null) { - return [5]; + return {_:5}; } else { // Object type but not array - it's a dictionary. // The RFC doesn't say anything about the ordering of keys, but @@ -86,18 +86,18 @@ } var xs = [0]; for(var i = 0; i < ks.length; i++) { - xs = [1, [0, ks[i], toHS(obj[ks[i]])], xs]; + xs = {_:1, a:{_:0, a:ks[i], b:toHS(obj[ks[i]])}, b:xs}; } - return [4, xs]; + return {_:4, a:xs}; } } } function arr2lst_json(arr, elem) { if(elem >= arr.length) { - return [0]; + return __Z; } - return [1, toHS(arr[elem]), new T(function() {return arr2lst_json(arr,elem+1);}),true] + return {_:1, a:toHS(arr[elem]), b:new T(function() {return arr2lst_json(arr,elem+1);}),c:true} } /* gettimeofday(2) */ diff --git a/libraries/haste-lib/src/Haste/Binary.hs b/libraries/haste-lib/src/Haste/Binary.hs --- a/libraries/haste-lib/src/Haste/Binary.hs +++ b/libraries/haste-lib/src/Haste/Binary.hs @@ -11,7 +11,7 @@ module Haste.Binary.Get, MonadBlob (..), Binary (..), getBlobText, Blob, BlobData, - blobSize, blobDataSize, toByteString, toBlob, strToBlob, + blobSize, blobDataSize, toByteString, fromByteString, toBlob, strToBlob, encode, decode, decodeBlob )where import Data.Int diff --git a/libraries/haste-lib/src/Haste/Binary/Types.hs b/libraries/haste-lib/src/Haste/Binary/Types.hs --- a/libraries/haste-lib/src/Haste/Binary/Types.hs +++ b/libraries/haste-lib/src/Haste/Binary/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-} module Haste.Binary.Types ( Blob (..), BlobData (..), - blobSize, blobDataSize, toByteString, toBlob, strToBlob + blobSize, blobDataSize, toByteString, fromByteString, toBlob, strToBlob ) where import Haste.Prim import Haste.Foreign @@ -34,6 +34,11 @@ toByteString = error "Haste.Binary.Types.toByteString called in browser context!" +-- | Convert a ByteString to a BlobData. Only usable server-side. +fromByteString :: BS.ByteString -> BlobData +fromByteString = + error "Haste.Binary.Types.toByteString called in browser context!" + -- | Convert a piece of BlobData back into a Blob. toBlob :: BlobData -> Blob toBlob (BlobData 0 len buf) = @@ -88,6 +93,10 @@ -- | Convert a BlobData to a ByteString. Only usable server-side. toByteString :: BlobData -> BS.ByteString toByteString (BlobData bd) = bd + +-- | Convert a ByteString to a BlobData. Only usable server-side. +fromByteString :: BS.ByteString -> BlobData +fromByteString = BlobData -- | Convert a piece of BlobData back into a Blob. toBlob :: BlobData -> Blob diff --git a/libraries/haste-lib/src/Haste/Compiler.hs b/libraries/haste-lib/src/Haste/Compiler.hs --- a/libraries/haste-lib/src/Haste/Compiler.hs +++ b/libraries/haste-lib/src/Haste/Compiler.hs @@ -33,22 +33,22 @@ inTempDirectory $ do fil <- case inp of InFile f -> return $ if isRelative f then incdir curdir f else f - InString s -> file "Main.hs" s >>= \() -> return "Main.hs" - (f,_,e) <- genericRun hasteBinary (fil : idir curdir : mkFlags cf) "" - if not f + InString s -> output "Main.hs" s >> return "Main.hs" + (f, _, e) <- genericRun hasteBinary (fil : idir curdir : mkFlags cf) "" + if f /= 0 then do - return $ Failure e + return $ Haste.Compiler.Failure e else do case cfTarget cf of TargetFile tgt -> do - return $ Success $ OutFile tgt + return $ Haste.Compiler.Success $ OutFile tgt TargetString -> do - (Success . OutString) `fmap` file "haste.out" + (Haste.Compiler.Success . OutString) `fmap` input "haste.out" case eresult of Right result -> return result - Left e -> - return $ Failure $ "Run-time failure during compilation: " ++ e + Left e -> return $ Haste.Compiler.Failure $ + "Run-time failure during compilation: " ++ exitString e where incdir cur = if isRelative dir then cur dir else dir idir cur = "-i" ++ incdir cur diff --git a/libraries/haste-lib/src/Haste/DOM.hs b/libraries/haste-lib/src/Haste/DOM.hs --- a/libraries/haste-lib/src/Haste/DOM.hs +++ b/libraries/haste-lib/src/Haste/DOM.hs @@ -2,7 +2,7 @@ -- | DOM manipulation functions using 'String' for string representation. module Haste.DOM ( -- From Haste.DOM.Core - AttrName (..), Attribute, IsElem (..), Elem, + AttrName (..), Attribute, IsElem (..), Elem (..), attribute, set, with, children, click, focus, blur, document, documentBody, appendChild, addChild, addChildBefore, insertChildBefore, getFirstChild, getLastChild, getChildren, diff --git a/libraries/haste-lib/src/Haste/DOM/Core.hs b/libraries/haste-lib/src/Haste/DOM/Core.hs --- a/libraries/haste-lib/src/Haste/DOM/Core.hs +++ b/libraries/haste-lib/src/Haste/DOM/Core.hs @@ -80,7 +80,8 @@ -- | Get the element representing the object. elemOf :: a -> Elem - -- | Attempt to create an object from an 'Elem'. + -- | Attempt to create a DOM element backed object from an 'Elem'. + -- The default instance always returns @Nothing@. fromElem :: Elem -> IO (Maybe a) fromElem = const $ return Nothing @@ -94,6 +95,7 @@ = PropName !JSString | StyleName !JSString | AttrName !JSString + deriving (Eq, Ord) instance IsString AttrName where fromString = PropName . fromString @@ -167,13 +169,12 @@ documentBody :: Elem documentBody = constant "document.body" --- | Append the first element as a child of the second element. +-- | Append the second element as a child of the first. appendChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m () appendChild parent child = liftIO $ jsAppendChild (elemOf child) (elemOf parent) {-# DEPRECATED addChild "Use appendChild instead. Note that appendChild == flip addChild." #-} --- | DEPRECATED: use 'appendChild' instead! --- Note that @appendChild == flip addChild@. +-- | Append the first element as a child of the second element. addChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m () addChild = flip appendChild @@ -188,9 +189,11 @@ liftIO $ jsAddChildBefore (elemOf child) (elemOf parent) (elemOf oldChild) {-# DEPRECATED addChildBefore "Use insertChildBefore instead. Note insertChildBefore == \\parent new old -> addChildBefore new parent old." #-} --- | DEPRECATED: use 'insertChildBefore' instead! --- Note that --- @insertChildBefore == \parent new old -> addChildBefore new parent old@. +-- | Insert an element into a container, before another element. +-- For instance: +-- @ +-- addChildBefore childToAdd theContainer olderChild +-- @ addChildBefore :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> child -> m () addChildBefore child parent oldChild = insertChildBefore parent oldChild child diff --git a/libraries/haste-lib/src/Haste/DOM/JSString.hs b/libraries/haste-lib/src/Haste/DOM/JSString.hs --- a/libraries/haste-lib/src/Haste/DOM/JSString.hs +++ b/libraries/haste-lib/src/Haste/DOM/JSString.hs @@ -2,7 +2,7 @@ -- | DOM manipulation functions using 'JSString' for string representation. module Haste.DOM.JSString ( -- From Haste.DOM.Core - AttrName (..), Attribute, IsElem (..), Elem, + AttrName (..), Attribute, IsElem (..), Elem (..), attribute, set, with, children, click, focus, blur, document, documentBody, appendChild, addChild, addChildBefore, insertChildBefore, getFirstChild, getLastChild, getChildren, diff --git a/libraries/haste-lib/src/Haste/Events/Core.hs b/libraries/haste-lib/src/Haste/Events/Core.hs --- a/libraries/haste-lib/src/Haste/Events/Core.hs +++ b/libraries/haste-lib/src/Haste/Events/Core.hs @@ -41,8 +41,8 @@ } -- | Unregister an event handler. -unregisterHandler :: HandlerInfo -> IO () -unregisterHandler (HandlerInfo ev el f) = unregEvt el ev f +unregisterHandler :: MonadIO m => HandlerInfo -> m () +unregisterHandler (HandlerInfo ev el f) = liftIO $ unregEvt el ev f -- | Reference to the event currently being handled. {-# NOINLINE evtRef #-} diff --git a/libraries/haste-lib/src/Haste/Graphics/Canvas.hs b/libraries/haste-lib/src/Haste/Graphics/Canvas.hs --- a/libraries/haste-lib/src/Haste/Graphics/Canvas.hs +++ b/libraries/haste-lib/src/Haste/Graphics/Canvas.hs @@ -83,15 +83,15 @@ jsDrawImage = ffi "(function(ctx,i,x,y){ctx.drawImage(i,x,y);})" jsDrawImageClipped :: Ctx -> Elem - -> Double -> Double - -> Double -> Double -> Double -> Double - -> IO () + -> Double -> Double + -> Double -> Double -> Double -> Double + -> IO () jsDrawImageClipped = ffi "(function(ctx, img, x, y, cx, cy, cw, ch){\ ctx.drawImage(img, cx, cy, cw, ch, x, y, cw, ch);})" jsDrawImageScaled :: Ctx -> Elem - -> Double -> Double -> Double -> Double - -> IO () + -> Double -> Double -> Double -> Double + -> IO () jsDrawImageScaled = ffi "(function(ctx, img, x, y, w, h){\ ctx.drawImage(img, x, y, w, h);})" @@ -164,6 +164,7 @@ instance IsElem Canvas where elemOf (Canvas _ctx e) = e + fromElem = getCanvas instance IsElem Bitmap where elemOf (Bitmap e) = e @@ -211,7 +212,7 @@ instance FromAny Canvas where fromAny c = do - mcan <- fromAny c >>= getCanvas + mcan <- fromAny c >>= fromElem case mcan of Just can -> return can _ -> error "Attempted to turn a non-canvas element into a Canvas!" @@ -267,6 +268,7 @@ e <- elemById (toJSString eid) maybe (return Nothing) getCanvas e +{-# DEPRECATED getCanvas "use the more general fromElem instead." #-} -- | Create a 2D drawing context from a DOM element. getCanvas :: MonadIO m => Elem -> m (Maybe Canvas) getCanvas e = liftIO $ do diff --git a/libraries/haste-lib/src/Haste/Hash.hs b/libraries/haste-lib/src/Haste/Hash.hs --- a/libraries/haste-lib/src/Haste/Hash.hs +++ b/libraries/haste-lib/src/Haste/Hash.hs @@ -8,7 +8,8 @@ import Haste.Prim -- | Register a callback to be run whenever the URL hash changes. --- The two arguments of the callback are the new and old hash respectively. +-- The first and second argument of the callback are the old and new and +-- hash respectively. onHashChange :: MonadIO m => (String -> String -> IO ()) -> m () diff --git a/src/Data/JSTarget.hs b/src/Data/JSTarget.hs deleted file mode 100644 --- a/src/Data/JSTarget.hs +++ /dev/null @@ -1,17 +0,0 @@ --- | Javascript subset as a target language for compilers. -module Data.JSTarget ( - module Constr, module Op, module Optimize, module Trav, - PPOpts (..), pretty, runPP, prettyProg, def, - Arity, Comment, Name (..), Var (..), LHS, Call, - Lit, Exp, Stm, Alt, Module (..), - foreignModule, moduleOf, pkgOf, blackHole, blackHoleVar, merge - ) 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 deleted file mode 100644 --- a/src/Data/JSTarget/AST.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances, CPP, - OverloadedStrings #-} -module Data.JSTarget.AST where -import qualified Data.Set as S -#if __GLASGOW_HASKELL__ >= 708 -import qualified Data.Map.Strict as M -#else -import qualified Data.Map as M -#endif -import Data.JSTarget.Op -import qualified Data.ByteString as BS - -type Arity = Int -type Comment = BS.ByteString -type Reorderable = Bool - --- | A Name consists of a variable name and optional (package, module) --- information. -data Name = Name { - nameIdent :: !BS.ByteString, - nameQualifier :: !(Maybe (BS.ByteString, BS.ByteString)) - } deriving (Eq, Ord, Show) - -class HasModule a where - moduleOf :: a -> Maybe BS.ByteString - pkgOf :: a -> Maybe BS.ByteString - -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 - -type KnownLoc = Bool - --- | Representation of variables. -data Var where - Foreign :: !BS.ByteString -> Var - -- | Being a "known location" means that we can never substitute this - -- variable for another one, as it is used to hold "return values" from - -- case statements, tail loopification and similar. - -- If a variable is *not* a known location, then we may always perform the - -- substitution @a=b ; exp => exp [a/b]@. - Internal :: !Name -> !Comment -> !KnownLoc -> Var - deriving (Show) - -isKnownLoc :: Var -> Bool -isKnownLoc (Internal _ _ knownloc) = knownloc -isKnownLoc _ = False - -instance Eq Var where - {-# INLINE (==) #-} - (Foreign f1) == (Foreign f2) = f1 == f2 - (Internal i1 _ _) == (Internal i2 _ _) = i1 == i2 - _ == _ = False - -instance Ord Var where - {-# INLINE compare #-} - 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. -data LHS where - -- | Introduce a new variable. May be reorderable. - -- Invariant: a NewVar must be the first occurrence of a 'Var' in its - -- scope. - NewVar :: !Reorderable -> !Var -> LHS - -- | Assign a value to an arbitrary LHS expression. May be reorderable. - LhsExp :: !Reorderable -> !Exp -> LHS - deriving (Eq, Show) - --- | Distinguish between normal, optimized and method calls. --- Normal and optimized calls take a boolean indicating whether the called --- function should trampoline or not. This defaults to True, and should --- only be set to False when there is absolutely no possibility whatsoever --- that the called function will tailcall. -data Call where - Normal :: !Bool -> Call - Fast :: !Bool -> Call - Method :: !BS.ByteString -> Call - deriving (Eq, Show) - --- | Literals; nothing fancy to see here. -data Lit where - LNum :: !Double -> Lit - LStr :: !BS.ByteString -> Lit - LBool :: !Bool -> Lit - LInt :: !Integer -> Lit - LNull :: Lit - deriving (Eq, Show) - --- | Expressions. Completely predictable. -data Exp where - Var :: !Var -> Exp - Lit :: !Lit -> Exp - -- | A literal JS snippet. - -- Invariant: JSLits must not perform side effects or significant - -- computation. - JSLit :: !BS.ByteString -> Exp - Not :: !Exp -> Exp - BinOp :: !BinOp -> Exp -> !Exp -> Exp - Fun :: ![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 - Eval :: !Exp -> Exp - Thunk :: !Bool -> !Stm -> Exp -- Thunk may be updatable or not - deriving (Eq, Show) - --- | Is the given expression guaranteed to not be a thunk? --- @definitelyNotThunk e <=> safe to skip evaluation of e@ -definitelyNotThunk :: Exp -> Bool -definitelyNotThunk (Lit {}) = True -definitelyNotThunk (JSLit {}) = True -definitelyNotThunk (Not {}) = True -definitelyNotThunk (BinOp {}) = True -definitelyNotThunk (Fun {}) = True -definitelyNotThunk (Arr {}) = True -definitelyNotThunk (Eval {}) = True -definitelyNotThunk _ = False - --- | 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] -> !Stm -> Stm - Forever :: !Stm -> Stm - Assign :: !LHS -> !Exp -> !Stm -> Stm - Return :: !Exp -> Stm - Cont :: Stm - Stop :: Stm -- Do nothing at all past this point - Tailcall :: !Exp -> Stm - ThunkRet :: !Exp -> Stm -- Return from a Thunk - deriving (Eq, Show) - --- | Case alternatives - an expression to match and a branch. -type Alt = (Exp, Stm) - --- | Represents a module. A module has a name, an owning --- package, a dependency map of all its definitions, and a bunch of --- definitions. -data Module = Module { - modPackageId :: !BS.ByteString, - modName :: !BS.ByteString, - modDeps :: M.Map Name (S.Set Name), - modDefs :: M.Map Name Exp - } - --- | Merge two modules. The module and package IDs of the second argument are --- used, and the second argument will take precedence for symbols which exist --- in both. -merge :: Module -> Module -> Module -merge m1 m2 = Module { - modPackageId = modPackageId m2, - modName = modName m2, - modDeps = M.union (modDeps m1) (modDeps m2), - modDefs = M.union (modDefs m1) (modDefs m2) - } - --- | Imaginary module for foreign code that may need one. -foreignModule :: Module -foreignModule = Module { - 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 False $ Var blackHoleVar - --- | The variable of the blackHole LHS. -blackHoleVar :: Var -blackHoleVar = Internal (Name "" (Just ("$blackhole", "$blackhole"))) "" False - --- | 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 (AssignEx _ _) = 0 -expPrec (Not _) = 500 -expPrec _ = 1000 diff --git a/src/Data/JSTarget/Binary.hs b/src/Data/JSTarget/Binary.hs deleted file mode 100644 --- a/src/Data/JSTarget/Binary.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# 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 Module where - put (Module pkgid name deps defs) = - put pkgid >> put name >> put deps >> put defs - get = Module <$> get <*> get <*> get <*> get - -instance Binary Var where - put (Foreign str) = - putWord8 0 >> put str - put (Internal name comment knownloc) = - putWord8 1 >> put name >> put comment >> put knownloc - - get = do - which <- getWord8 - case which of - 0 -> Foreign <$> get - 1 -> Internal <$> get <*> get <*> get - -instance Binary LHS where - put (NewVar r v) = putWord8 0 >> put r >> put v - put (LhsExp r e) = putWord8 1 >> put r >> put e - - get = getWord8 >>= ([NewVar <$> get <*> get, - LhsExp <$> get <*> get] !!) . fromIntegral - -instance Binary Call where - put (Normal tr) = putWord8 0 >> put tr - put (Fast tr) = putWord8 1 >> put tr - put (Method m) = putWord8 2 >> put m - - get = do - tag <- fromIntegral <$> getWord8 - [Normal <$> get, Fast <$> get,Method <$> get] !! tag - -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 (JSLit l) = putWord8 2 >> put l - put (Not ex) = putWord8 3 >> put ex - put (BinOp op a b) = putWord8 4 >> put op >> put a >> put b - put (Fun as body) = putWord8 5 >> put as >> put body - put (Call a c f xs) = putWord8 6 >> put a >> put c >> put f >> put xs - put (Index arr ix) = putWord8 7 >> put arr >> put ix - put (Arr exs) = putWord8 8 >> put exs - put (AssignEx l r) = putWord8 9 >> put l >> put r - put (IfEx c th el) = putWord8 10 >> put c >> put th >> put el - put (Eval x) = putWord8 11 >> put x - put (Thunk upd x) = putWord8 12 >> put upd >> put x - - get = do - tag <- getWord8 - case tag of - 0 -> Var <$> get - 1 -> Lit <$> get - 2 -> JSLit <$> get - 3 -> Not <$> get - 4 -> BinOp <$> get <*> get <*> get - 5 -> Fun <$> get <*> get - 6 -> Call <$> get <*> get <*> get <*> get - 7 -> Index <$> get <*> get - 8 -> Arr <$> get - 9 -> AssignEx <$> get <*> get - 10 -> IfEx <$> get <*> get <*> get - 11 -> Eval <$> get - 12 -> Thunk <$> 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 (Stop) = - putWord8 5 - put (Tailcall ex) = - putWord8 6 >> put ex - put (ThunkRet ex) = - putWord8 7 >> put ex - - 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 -> pure Stop - 6 -> Tailcall <$> get - 7 -> ThunkRet <$> get - 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 StrictEq = putWord8 8 - put Neq = putWord8 9 - put StrictNeq = putWord8 10 - put LT = putWord8 11 - put GT = putWord8 12 - put LTE = putWord8 13 - put GTE = putWord8 14 - put Shl = putWord8 15 - put ShrL = putWord8 16 - put ShrA = putWord8 17 - put BitAnd = putWord8 18 - put BitOr = putWord8 19 - put BitXor = putWord8 20 - - get = (opTbl !) <$> getWord8 - -instance Binary Name where - put (Name name owner) = put name >> put owner - get = Name <$> 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, StrictEq, Neq, StrictNeq, - LT, GT, LTE, GTE, Shl, ShrL, ShrA, BitAnd, BitOr, BitXor] diff --git a/src/Data/JSTarget/Constructors.hs b/src/Data/JSTarget/Constructors.hs deleted file mode 100644 --- a/src/Data/JSTarget/Constructors.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TupleSections, CPP, OverloadedStrings #-} -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -#endif --- | User interface for the JSTarget AST. -module Data.JSTarget.Constructors where -import Data.JSTarget.AST -import Data.JSTarget.Op -import qualified Data.ByteString as BS -import qualified Data.ByteString.UTF8 as BS - --- | Literal types. -class Literal a where - lit :: a -> Exp - -instance Literal Lit where - lit = Lit - -instance Literal Double where - lit = lit . LNum - -instance Literal Integer where - lit = lit . LInt - -instance Literal Bool where - lit = lit . LBool - -instance Literal BS.ByteString where - lit = lit . LStr - -instance Literal [Char] where - lit = lit . BS.fromString - -#if __GLASGOW_HASKELL__ < 710 -instance Literal a => Literal [a] where -#else -instance {-# OVERLAPPABLE #-} Literal a => Literal [a] where -#endif - lit = Arr . map lit - -instance Literal Exp where - lit = id - -instance Literal Var where - lit = Var - -litN :: Double -> Exp -litN = lit - -litS :: BS.ByteString -> Exp -litS = lit - --- | Create a foreign variable. Foreign vars will not be subject to any name --- mangling. -foreignVar :: BS.ByteString -> Var -foreignVar = Foreign - --- | A regular, internal variable. Subject to name mangling. -internalVar :: Name -> BS.ByteString -> Var -internalVar n c = Internal n c False - --- | A variable serving as a known location, to store return values from --- expressions that get compiled into statements. -knownLocation :: Name -> BS.ByteString -> Var -knownLocation n c = Internal n c True - --- | Create a name, qualified or not. -name :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) -> Name -name = Name - --- | A variable expression, for convenience. -var :: Name -> BS.ByteString -> Exp -var n comment = Var $ internalVar n comment - --- | Turn a Var into an expression. -varExp :: Var -> Exp -varExp = Var - --- | Call to a native method on an object. Always saturated. -callMethod :: Exp -> BS.ByteString -> [Exp] -> Exp -callMethod obj meth args = Call 0 (Method meth) obj args - --- | Foreign function call. Always saturated, never trampolines. -callForeign :: BS.ByteString -> [Exp] -> Exp -callForeign f = Call 0 (Fast False) (Var $ foreignVar f) - --- | A normal function call. May be unsaturated. A saturated call is always --- turned into a fast call. -call :: Arity -> Exp -> [Exp] -> Exp -call arity f xs = foldApp $ Call (arity - length xs) (Normal True) f xs - -callSaturated :: Exp -> [Exp] -> Exp -callSaturated f xs = Call 0 (Fast True) f 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 tramp) (Call _ (Normal _) f args) args') = - Call arity (Normal tramp) (foldApp f) (args ++ args') -foldApp (Call 0 (Normal tramp) f args) = - Call 0 (Fast tramp) f args -foldApp (Call arity (Normal tramp) f args) | arity > 0 = - Fun newargs $ Return - $ Call arity (Fast tramp) f (args ++ map Var newargs) - where - newargs = newVars "_fa_" arity -foldApp ex = - ex - --- | Introduce n new vars. -newVars :: String -> Int -> [Var] -newVars prefix n = - map nv [1..n] - where - nv i = Internal (Name (BS.fromString $ prefix++show i) Nothing) "" False - --- | Create a thunk. -thunk :: Bool -> Stm -> Exp -thunk = Thunk - --- | Evaluate an expression that may or may not be a thunk. -eval :: Exp -> Exp -eval ex - | definitelyNotThunk ex = ex - | otherwise = Eval ex - --- | Create a tail call. -tailcall :: Exp -> Stm -tailcall = Tailcall - --- | A binary operator. -binOp :: BinOp -> Exp -> Exp -> Exp -binOp = BinOp - --- | Negate an expression. -not_ :: Exp -> Exp -not_ = Not - --- | Index into an array. -index :: Exp -> Exp -> Exp -index = Index - --- | Create a function. -fun :: [Var] -> Stm -> Exp -fun = Fun - --- | Create an array of expressions. -array :: [Exp] -> Exp -array = Arr - --- | 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_ :: Exp -> (Stm -> Stm) -> [(Exp, Stm -> Stm)] -> Stm -> Stm -case_ ex def alts = Case ex (def stop) (map (\(e, s) -> (e, s stop)) alts) - --- | Return from a function. -ret :: Exp -> Stm -ret = Return - --- | Return from a thunk. -thunkRet :: Exp -> Stm -thunkRet = ThunkRet - --- | Create a new var with a new value. -newVar :: Reorderable -> Var -> Exp -> Stm -> Stm -newVar r lhs = Assign (NewVar r lhs) - --- | Reuse an old variable. -assignVar :: Reorderable -> Var -> Exp -> Stm -> Stm -assignVar r lhs = Assign (LhsExp r (Var lhs)) - --- | Assignment without var. Performed for the side effect, so never --- reorderable. -sideEffectingAssign :: Exp -> Exp -> Stm -> Stm -sideEffectingAssign lhs = Assign (LhsExp False lhs) - --- | Assignment expression. -assignEx :: Exp -> Exp -> Exp -assignEx = AssignEx - --- | Terminate a statement without doing anything at all. -stop :: Stm -stop = Stop diff --git a/src/Data/JSTarget/Op.hs b/src/Data/JSTarget/Op.hs deleted file mode 100644 --- a/src/Data/JSTarget/Op.hs +++ /dev/null @@ -1,85 +0,0 @@ -module Data.JSTarget.Op where -import Prelude hiding (GT, LT) - -data BinOp - = Add - | Mul - | Sub - | Div - | Mod - | And - | Or - | Eq - | StrictEq - | Neq - | StrictNeq - | 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 StrictEq = "===" - show Neq = "!=" - show StrictNeq = "!==" - 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 StrictEq = 30 -opPrec Neq = 30 -opPrec StrictNeq = 30 -opPrec BitAnd = 25 -opPrec BitXor = 24 -opPrec BitOr = 23 -opPrec And = 20 -opPrec Or = 10 - --- | Is the given operator associative? -opIsAssoc :: BinOp -> Bool -opIsAssoc Mul = True -opIsAssoc Add = True -opIsAssoc BitAnd = True -opIsAssoc BitOr = True -opIsAssoc BitXor = True -opIsAssoc And = True -opIsAssoc Or = True -opIsAssoc _ = False diff --git a/src/Data/JSTarget/Optimize.hs b/src/Data/JSTarget/Optimize.hs deleted file mode 100644 --- a/src/Data/JSTarget/Optimize.hs +++ /dev/null @@ -1,773 +0,0 @@ -{-# LANGUAGE PatternGuards, TupleSections, DoAndIfThenElse, OverloadedStrings #-} --- | 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 Control.Monad -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.ByteString.Char8 as BS - --- | Turn tail recursion into loops. -fixTailCalls :: Var -> Exp -> TravM Exp -fixTailCalls fun ast = do - ast' <- assignToSubst ast >>= tailLoopify fun - mapJS (const True) pure loopify ast' - where - loopify (Assign lhs@(NewVar _ f) body next) = - Assign lhs <$> (assignToSubst body >>= tailLoopify f) <*> pure next - loopify stm = - return stm - --- TODO: tryTernary may inline calls that would otherwise be in tail position --- which is something we'd really like to avoid. -optimizeFun :: Var -> Exp -> Exp -optimizeFun f ast = - runTravM $ do - shrinkCase ast - >>= inlineAssigns - >>= optimizeArrays - >>= inlineReturns - >>= zapJSStringConversions - >>= optimizeThunks - >>= optimizeArrays - >>= fixTailCalls f - >>= inlineShortJumpTailcall - >>= trampoline - >>= ifReturnToTernary - >>= smallStepInline - >>= inlineJSPrimitives - >>= mapJS (const True) pure (pure . removeNonsenseAssigns) - -topLevelInline :: Stm -> Stm -topLevelInline ast = - runTravM $ do - pure ast - >>= unevalLits - >>= inlineIntoEval - >>= inlineAssigns - >>= optimizeArrays - >>= optimizeThunks - >>= smallStepInline - >>= optimizeArrays - >>= zapJSStringConversions - >>= inlineJSPrimitives - >>= removeUselessEvals - >>= inlineAssigns - >>= smallStepInline - >>= inlineAssigns - >>= unTrampoline - --- | Attempt to turn two case branches into a ternary operator expression. -tryTernary :: Var - -> Exp - -> Exp - -> (Stm -> Stm) - -> [(Exp, Stm -> Stm)] - -> Maybe Exp -tryTernary self scrut retEx def [(m, alt)] = - runTravM opt - where - selfOccurs (Exp (Var v) _) = v == self - selfOccurs _ = False - def' = def $ Return retEx - alt' = alt $ Return retEx - 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'' <- inlineAssigns def' - alt'' <- inlineAssigns 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 scrut m) th el - _ -> - return Nothing -tryTernary _ _ _ _ _ = - Nothing - --- | Remove bogus assignments of the form @literal = exp@ and @_ = _@, --- which may arise from other optimizations. -removeNonsenseAssigns :: Stm -> Stm -removeNonsenseAssigns (Assign (LhsExp _ (Lit _)) _ next) = next -removeNonsenseAssigns (Assign (LhsExp _ a) b next) | a == b = next -removeNonsenseAssigns (Assign (NewVar _ a) (Var b) next) | a == b = next -removeNonsenseAssigns stm = stm - --- | 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 - --- | 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 => ast -> TravM ast -inlineAssigns ast = do - inlinable <- countVarOccs ast - mapJS (const True) return (inl inlinable) ast - where - -- Assume that an assignment that is never used is actually there for a - -- good reason and thus not inlinable. - isSafe i v - | Just Once <- M.lookup v i = True - | otherwise = False - - atLeastOnce i v - | Just occs <- M.lookup v i = occs > Never - | otherwise = False - - isJSLit (Exp (JSLit {}) _) = True - isJSLit _ = False - - isVar v (Exp (Var v') _) = v == v' - isVar _ _ = False - - isWritten v (Exp (AssignEx (Var v') _) _) = v == v' - isWritten v (Stm (Assign (LhsExp _ (Var v')) _ _) _) = v == v' - isWritten _ _ = False - - -- It's OK to inline lambda-likes into anything that's not a loop or a - -- function (thunks are OK because they only get evaluated once). - goodInlineTgt = not <$> isLoop .|. isFun - - -- Only inline safe-to-reorder vars - if a var is ever assigned to, it is - -- insanely unsafe to inline it. - inl safe keep@(Assign (NewVar True v) rhs next) = do - written <- occurrences (const True) (isWritten v) next - case rhs of - _ | written /= Never -> do - return keep - -- String lits: inline if used exactly once to avoid blowing up code size - l@(Lit (LStr _)) | isSafe safe v -> do - replaceEx (const True) (Var v) l next - - -- Other lits: inline if used at least once - l@(Lit _) | atLeastOnce safe v -> do - occs <- occurrences (const True) (isVar v) next - if occs > Never - then replaceEx (const True) (Var v) l next - else return keep - - -- Variables: inline if used at least once - v'@(Var {}) | atLeastOnce safe v -> do - occs <- occurrences (const True) (isVar v) next - if occs > Never - then replaceEx (const True) (Var v) v' next - else return keep - - -- Everything else: inline if only used once and doesn't contain - -- lambda-likes. Lambda-likes may be inlined if they occur exactly - -- once, and this occurrence is not in a lambda or a loop. - ex | isSafe safe v -> do - lambdaoccs <- occurrences (const True) (isLambda .|. isJSLit) ex - recursive <- occurrences (const True) (isVar v) ex - case (lambdaoccs, recursive) of - (Never, Never) -> do - (reps, next') <- replaceExWithCount (const True) (Var v) ex next - if reps == 1 - then return next' - else return keep - (Once, Never) -> do - -- If we only made a single replacement in a good inline target, - -- then we know that everything is OK. If not, we accidentally - -- inlined into a bad code block, so we discard the result. - (reps, next') <- replaceExWithCount goodInlineTgt (Var v) ex next - if reps == 1 - then return next' - else return keep - _ -> do - pure keep - _ -> do - pure keep - inl _ keep = do - pure keep - --- | Remove an occurrence of @ex = E(ex)@ or @lit = ex@. --- Only call this for @ex@ which are guaranteed to never be thunks. -removeUpdate :: (Var -> Bool) -> Stm -> Stm -removeUpdate p stm@(Assign _ _ next) | isEvalUpd p stm = next -removeUpdate _ stm = stm - --- | Turn the common pattern @var x = e ; x = E(x)@ into @var x = E(e)@. --- should run *after* 'unevalLits'. -inlineIntoEval :: JSTrav ast => ast -> TravM ast -inlineIntoEval ast = do - mapJS (const True) pure (pure . inline) ast - where - inline (Assign l@(NewVar _ v) r s@(Assign _ _ next)) - | isEvalUpd (== v) s = Assign l (Eval r) next - inline stm = stm - -isEvalUpd :: (Var -> Bool) -> Stm -> Bool -isEvalUpd p (Assign (LhsExp _ (Var v)) (Eval (Var v')) _) = p v && v == v' -isEvalUpd _ _ = False - --- | Turn if(foo) {return bar;} else {return baz;} into return foo ? bar : baz. -ifReturnToTernary :: JSTrav ast => ast -> TravM ast -ifReturnToTernary ast = do - mapJS (const True) return opt ast - where - opt (Case cond (Return el) [(ex, Return th)] _) = - pure $ Return $ IfEx (BinOp Eq cond ex) th el - opt stm = - pure stm - --- | Turn occurrences of [a,b][1] into b. -optimizeArrays :: JSTrav ast => ast -> TravM ast -optimizeArrays ast = - mapJS (const True) inlEx return ast - where - inlEx (Index (Arr xs) (Lit (LNum n))) = - return $ xs !! truncate n - inlEx x = - return x - --- | Remove calls to E() where we know for sure the argument is already --- evaluated. -removeUselessEvals :: JSTrav ast => ast -> TravM ast -removeUselessEvals ast = do - mapJS (const True) return opt ast - where - opt (Assign lhs@(NewVar _ l) rhs next) = do - Assign lhs rhs <$> case rhs of - Eval r@(Var _) -> removeEval (Var l) next >>= removeEval r - _ | isHNF rhs -> removeEval (Var l) next - | otherwise -> return next - opt stm = do - return stm - - isHNF (Lit {}) = True - isHNF (JSLit {}) = True - isHNF (Not {}) = True - isHNF (BinOp {}) = True - isHNF (Fun {}) = True - isHNF (Arr {}) = True - isHNF (Eval {}) = True - isHNF _ = False - - removeEval x = replaceEx (const True) (Eval x) x - --- | Turn toJSStr(unCStr(x)) into x, since rewrite rules absolutely refuse --- to work with unpackCString#. --- Also turn T(unCStr(x)) into unCStr(x) whenever x is a literal, since --- unCStr is evaluated lazily anyway. -zapJSStringConversions :: JSTrav ast => ast -> TravM ast -zapJSStringConversions ast = - mapJS (const True) opt return ast - where - opt (Call _ _ (Var (Foreign "toJSStr")) [ - Call _ _ (Var (Foreign "unCStr")) [x]]) = - return x - opt (Call _ _ (Var (Foreign "toJSStr")) [ - Eval (Call _ _ (Var (Foreign "unCStr")) [x])]) = - return x - opt (Thunk _ (Return x@(Call _ _ (Var (Foreign "unCStr")) [Lit _]))) = - return x - opt x = - return x - --- | Optimize thunks in the following ways: --- 1. A(thunk(return f), xs) --- => A(f, xs) --- 2. thunk(x@(JSLit s)) | s is a JS function object or marked eager --- => x --- 3. thunk(x@(Lit _)) --- => x --- 4. E(thunk(return x)) --- => x --- 5. E(x) | x is guaranteed to not be a thunk --- => x --- --- Note that #2 depends on the invariant of 'JSLit': a JS literal must not --- perform side effects or significant computation. -optimizeThunks :: JSTrav ast => ast -> TravM ast -optimizeThunks ast = - mapJS (const True) optEx return ast - where - optEx (Eval x) - | Just x' <- fromThunkEx x = return x' - | definitelyNotThunk x = return x - optEx ex@(Thunk _ _) - | Just l@(JSLit s) <- fromThunkEx ex = - case maybeExtractStrict s of - Just s' -> return $ JSLit s' - _ | isJSFunDecl s -> return l - | otherwise -> return ex - optEx ex@(Thunk _ _) - | Just l@(Lit _) <- fromThunkEx ex = return l - optEx (Call arity calltype f as) - | Just f' <- fromThunkEx f = return $ Call arity calltype f' as - optEx ex = return ex - -maybeExtractStrict :: BS.ByteString -> Maybe BS.ByteString -maybeExtractStrict js - | "__strict(" `BS.isPrefixOf` js && ")" `BS.isSuffixOf` js = - Just $ BS.init $ BS.drop 9 js - | otherwise = - Nothing - --- | Conservatively approximate whether a given JS literal is a function --- declaration or not. --- --- TODO: proper parsing here. -isJSFunDecl :: BS.ByteString -> Bool -isJSFunDecl s - | "function(" `BS.isPrefixOf` s && "}" `BS.isSuffixOf` s = True - | "(function(" `BS.isPrefixOf` s && ")" `BS.isSuffixOf` s = True - | otherwise = False - --- | Unpack the given expression if it's a thunk. -fromThunk :: Exp -> Maybe Stm -fromThunk (Thunk _ body) = Just body -fromThunk _ = Nothing - --- | Unpack the given expression if it's a thunk without internal bindings. -fromThunkEx :: Exp -> Maybe Exp -fromThunkEx ex = - case fromThunk ex of - Just (Return ex') -> Just ex' - Just (ThunkRet ex') -> Just ex' - _ -> Nothing - --- | Count the occurrences of all variables in an AST. -countVarOccs :: JSTrav ast => ast -> TravM (M.Map Var Occs) -countVarOccs ast = do - foldJS (\_ _->True) countOccs (M.empty) ast - where - updVar (Just occs) = Just (occs+Once) - updVar _ = Just Once - updVarAss (Just o) = Just o - updVarAss _ = Just Never - - {-# INLINE countOccs #-} - 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 (Stm (Assign (LhsExp True (Var v)) _ _) _) = - pure (M.alter updVarAss v m) - countOccs m _ = - pure m - --- | May the given expression ever tailcall? --- TODO: --- Be slightly smarter about handling locally defined functions; always --- counting a tailcall from a local as a tailcall from the containing --- function seems a bit too restrictive. On the other hand, this makes --- only a very slight difference in the number of unnecessary tailcalls --- eliminated. -mayTailcall :: JSTrav ast => ast -> TravM Bool -mayTailcall ast = do - foldJS enter countTCs False ast - where - enter True _ = False - enter _ (Exp (Thunk _ _) _) = False - enter _ (Exp (Fun _ _) _) = False - enter _ _ = True - countTCs _ (Stm (Tailcall _) _) = return True - countTCs acc _ = return acc - --- | Gather a map of all symbols which we know will never make tail calls. --- All calls to functions in this set can then safely be de-trampolined. -gatherNonTailcalling :: Stm -> TravM (S.Set Var) -gatherNonTailcalling stm = do - foldJS (\_ _ -> True) countTCs S.empty stm - where - countTCs s (Exp (Var v@(Foreign _)) _) = do - return $ S.insert v s - countTCs s (Stm (Assign (NewVar _ v) (JSLit {}) _) _) = do - return $ S.insert v s - countTCs s (Stm (Assign (NewVar _ v) (Fun _ body) _) _) = do - tc <- mayTailcall body - return $ if not tc then S.insert v s else s - countTCs s (Stm (Assign (LhsExp True (Var v)) (Fun _ body) _) _) = do - tc <- mayTailcall body - return $ if not tc then S.insert v s else s - countTCs s _ = do - return s - --- | Remove trampolines wherever possible. --- The trampoline machinery has some overhead; two extra activation records --- on the stack for a single, non-tailcalling function, to be precise. --- We observe that bouncing a function that is guaranteed to never tailcall --- is a waste of resources, so we can remove those bounces. --- Additionally, tailcalling a function which is guaranteed to not tailcall --- in turn is wasteful (see above comment about overhead), so we can --- eliminate any such function. --- Since the tailcalling machinery grows the stack by a total of three --- activation records for an arbitrary string of tailcalling functions, --- we can apply this procedure recursively three times and still be --- guaranteed to use no more stack frames than we would have without this --- optimization. --- --- Note that we can only do this for fast calls, as we need to be able to --- know exactly what function is actually called upon saturated application. -unTrampoline :: Stm -> TravM Stm -unTrampoline = go >=> go >=> go - where - go s = do - ntcs <- gatherNonTailcalling s - mapJS (const True) (unTr ntcs) (unTC ntcs) s - - unTr ntcs (Call ar (Fast True) f@(Var v) xs) - | v `S.member` ntcs = - return $ Call ar (Fast False) f xs - unTr _ c@(Call ar (Fast True) f@(Fun _ body) xs) = do - tc <- mayTailcall body - return $ if tc then c else Call ar (Fast False) f xs - unTr _ x = - return x - - -- If we know for certain that the function we're tailcalling will not - -- tailcall in turn we should not tailcall it, since that would mean two - -- activation records on the stack - one for the trampoline and one for - -- the function itself. - unTC ntcs (Tailcall c@(Call _ (Fast _) (Var v) _)) - | v `S.member` ntcs = - return $ Return c - unTC _ tc@(Tailcall c@(Call _ (Fast _) (Fun _ body) _)) = do - maytc <- mayTailcall body - if not maytc then return (Return c) else return tc - unTC _ x = - return x - --- | 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 - mapJS (const True) inl pure ast - where - inl (Fun as body) = Fun as <$> go Nothing body - inl (Thunk upd body) = Thunk upd <$> go Nothing body - inl ex = pure ex - - goAlt outside (ex, stm) = (ex,) <$> go outside stm - - go outside (Case c d as next) = do - next' <- go outside next - case returnLike next' of - outside'@(Just (Var _, _)) -> - Case c <$> go outside' d <*> mapM (goAlt outside') as <*> pure Stop - _ -> - Case c <$> go Nothing d <*> mapM (goAlt Nothing) as <*> pure next' - go _ (Forever s) = do - Forever <$> go Nothing s - go outside (Assign l@(NewVar _ lhs) r next) = do - next' <- go outside next - case (next', outside) of - (Stop, Just (Var v, ret)) | v == lhs -> return $ ret r - (Return (Var v), _) | v == lhs -> return $ Return r - (ThunkRet (Var v), _) | v == lhs -> return $ ThunkRet r - (Assign ll (Var v) Stop, _) | v == lhs -> return $ Assign ll r Stop - _ -> return $ Assign l r next' - go outside (Assign l r next) = do - Assign l r <$> go outside next - go _ stm = do - return stm - --- | Extract the expression returned from a Return of ThunkRet, as well as --- a function to recreate that type of return. -returnLike :: Stm -> Maybe (Exp, Exp -> Stm) -returnLike (Return e) = Just (e, Return) -returnLike (ThunkRet e) = Just (e, ThunkRet) -returnLike _ = Nothing - --- | Shrink case statements as much as possible. -shrinkCase :: JSTrav ast => ast -> TravM ast -shrinkCase = - mapJS (const True) pure shrink - where - shrink (Case _ def [] next) - | def == Stop = return next - | otherwise = replaceFinalStm next (== Stop) def - shrink stm = return stm - --- | Turn any calls in tail position into tailcalls. --- Must run after @tailLoopify@ or we won't get loops for simple tail --- recursive functions. -trampoline :: Exp -> TravM Exp -trampoline = mapJS (pure True) pure bounce - where - bounce (Return (Call arity call f args)) = do - return $ Tailcall $ Call arity call' f args - where - call' = - case call of - Normal _ -> Normal False - Fast _ -> Fast False - c -> c - bounce s = do - return s - --- | 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 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 - tailcalls <- occurrences (const True) isHiddenTailcall body - let nn = newName f - nv = NewVar False nn - body' = - Forever $ - Assign nv (Call 0 (Fast (tailcalls > Never)) (Fun args b) - (map Var args')) $ - Case (Var nn) (Return (Var nn)) [(Lit $ LNull, Stop)] $ - Stop - return $ Fun args' body' - False -> do - let c = Cont - body' <- mapJS (not <$> isLambda) pure (replaceByAssign c args) body - return $ Fun args (Forever body') - else do - return fun - where - isTailRec (Stm (Return (Call _ _ (Var f') _)) _) = f == f' - isTailRec _ = False - - isHiddenTailcall (Stm (Return (Call {})) _) = True - isHiddenTailcall _ = False - - -- Only traverse until we find a closure - createsClosures = foldJS (\acc _ -> not acc) isClosure False - isClosure _ (Exp (Fun _ _) _) = pure True - isClosure _ (Exp (Thunk _ _) _) = pure True - isClosure acc _ = pure acc - - -- Assign any changed vars, then loop. - replaceByAssign end as (Return (Call _ _ (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 False (Var v)) (Var $ newName v) final) - | otherwise = - (next, Assign (LhsExp False (Var v)) x final) - - newName (Internal (Name n mmod) _ _) = - Internal (Name (BS.cons ' ' n) mmod) "" True - newName n = - n - - contains (Var v) var = v == var - contains (Lit _) _ = False - contains (JSLit _) _ = 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] - contains (Eval x) var = x `contains` var - contains (Thunk _ _) _ = False -tailLoopify _ fun = do - return fun - --- | Inline a tailcalled function @f@ when: --- --- * @f@ does not refer to itself; and --- * @f@ is defined immediately before its call site. --- (@let f = ... in tailcall f@) --- --- Should be called *after* 'tailLoopify' but *before* trampoline for best --- effect. -inlineShortJumpTailcall :: JSTrav ast => ast -> TravM ast -inlineShortJumpTailcall ast = do - mapJS (const True) return inl ast - where - inl stm@(Assign (NewVar _ f) (Fun as b) tc) - | Just (f', as') <- getTailcallInfo tc, f == f' = do - occs <- occurrences (const True) (isEqualTo f) b - case (occs, zipAssign (map (NewVar True) as) as' b) of - (Never, Just b') -> return b' - _ -> return stm - inl stm = - return stm - isEqualTo v' (Exp (Var v) _) = v == v' - isEqualTo _ _ = False - --- | Extract the function being called and its argument list from a --- @Tailcall (Call ...)@ or @Return (Call ...)@, provided that the call is --- completely saturated. -getTailcallInfo :: Stm -> Maybe (Var, [Exp]) -getTailcallInfo (Tailcall (Call 0 _ (Var f) as)) = Just (f, as) -getTailcallInfo (Return (Call 0 _ (Var f) as)) = Just (f, as) -getTailcallInfo _ = Nothing - --- | Assign several variables, before executing a statement. -zipAssign :: [LHS] -> [Exp] -> Stm -> Maybe Stm -zipAssign l r final - | length l == length r = Just $ go l r - | otherwise = Nothing - where - go (v:vs) (x:xs) = Assign v x (go vs xs) - go [] [] = final - go _ _ = error "zipAssign: different number of lhs and rhs!" - --- | Eliminate evaluation of vars that are guaranteed not to be thunks. --- Mainly useful in 'topLevelInline'. -unevalLits :: JSTrav ast => ast -> TravM ast -unevalLits ast = do - lits <- foldJS (\_ _ -> True) gatherLits S.empty ast - mapJS (const True) pure (pure . removeUpdate (`S.member` lits)) ast - where - gatherLits s (Stm (Assign (NewVar _ v) rhs _) _) - | definitelyNotThunk rhs = pure $ S.insert v s - | Var v' <- rhs, v' `S.member` s = pure $ S.insert v s - gatherLits s _ = pure s - --- | Inline calls to JS @eval@, @__set@, @__get@ and @__has@ and apply --- functions for "Haste.Foreign". -inlineJSPrimitives :: JSTrav ast => ast -> TravM ast -inlineJSPrimitives = - inlineFuns >=> optimizeThunks - where - inlineFuns = mapJS (const True) (return . inl) return - inl ex@(Call _ (Fast _) (Var (Foreign fn)) args) = - case (fn, args) of - ("eval", [Lit (LStr s)]) -> JSLit s - ("__app0", [f]) -> Call 0 (Fast False) f [] - ("__app1", f:xs) -> Call 0 (Fast False) f xs - ("__app2", f:xs) -> Call 0 (Fast False) f xs - ("__app3", f:xs) -> Call 0 (Fast False) f xs - ("__app4", f:xs) -> Call 0 (Fast False) f xs - ("__app5", f:xs) -> Call 0 (Fast False) f xs - ("__get", [o, k]) -> Index o k - ("__set", [o, k, v]) -> AssignEx (Index o k) v - ("__has", [o, k]) -> BinOp StrictNeq (Index o k) - (JSLit "undefined") - _ -> ex - inl ex = - ex - --- | Turn all assignments of the form @var v1 = e ; exp@ into @exp[v1/e]@, --- provided that @v1@ is not used as a known location and @e@ is either a --- variable or a non-string literal. --- Also does not inline vars into lambdas. --- Should go before 'tailLoopify'. -assignToSubst :: JSTrav ast => ast -> TravM ast -assignToSubst ast = do - mapJS (const True) return inl ast - where - inl stm@(Assign (NewVar _ v) x next) | not (isKnownLoc v) = do - case x of - (Var _) -> do - -- TODO: this can be replaced by a map (to replace) and a count of - -- remaining occurrences of v (fold) - (c, stm') <- replaceExWithCount (isSafeForInlining) (Var v) x next - (c', _) <- replaceExWithCount (pure True) (Var v) x next - if c == c' - then return stm' -- No occurrences inside lambda - else return stm - (Lit (LStr _)) -> return stm - (Lit _) -> replaceEx (pure True) (Var v) x next - _ -> return stm - inl stm = do - return stm - --- | Perform various trivially correct local inlinings: --- var x = e; return [0, e] (boxing at the end of a thunk/function) --- => [0, e] --- thunk(x) where x is non-computing and non-recursive --- => x -smallStepInline :: JSTrav ast => ast -> TravM ast -smallStepInline ast = do - mapJS (const True) return inl ast - where - inl (Assign (NewVar _ v) ex (Return (Arr [l@(Lit _), Var v']))) - | v == v' = - return (Return (Arr [l, ex])) - inl (Assign (NewVar _ v) ex (ThunkRet (Arr [l@(Lit _), Var v']))) - | v == v' = - return (ThunkRet (Arr [l, ex])) - -- Unpack thunks which don't provide actual laziness. - inl (Assign lhs@(NewVar _ v) t@(Thunk _ _) next) - | Just ex <- fromThunkEx t, safeToUnThunk ex = do - case ex of - Thunk _ _ -> return $ Assign lhs ex next - _ -> Assign lhs ex <$> eliminateEvalOf v next - -- Merge @a = eval(a) ; a = eval(a)@ into a single eval. - inl stm@(Assign (LhsExp _ (Var v1)) (Eval (Var v1')) next) - | v1 == v1' = do - case next of - stm'@(Assign (LhsExp _ (Var v2)) (Eval (Var v2')) _) - | v1 == v2 && v1' == v2' -> do - return stm' - _ -> do - return stm - inl stm = - return stm - --- | Eliminate elimination of a variable. Only use when *absolutely certain* --- that the variable can never be a thunk. -eliminateEvalOf :: JSTrav ast => Var -> ast -> TravM ast -eliminateEvalOf v ast = mapJS (const True) return elim ast - where - elim (Assign (LhsExp _ (Var v')) (Eval (Var v'')) next) - | v' == v'' && v == v' = - return next - elim stm = - return stm - --- | Is the given expression safe to extract from a thunk? --- An expression is safe to unthunk iff evaluating it will not cause --- computation to take place or a variable to be dereferenced. -safeToUnThunk :: Exp -> Bool -safeToUnThunk ex = - case ex of - Lit _ -> True - JSLit l -> isJSFunDecl l - Fun _ _ -> True - Thunk _ _ -> True - Arr arr -> all safeToUnThunk arr - _ -> False diff --git a/src/Data/JSTarget/PP.hs b/src/Data/JSTarget/PP.hs deleted file mode 100644 --- a/src/Data/JSTarget/PP.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE OverloadedStrings, FlexibleInstances, - GeneralizedNewtypeDeriving, CPP #-} --- | 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 qualified Data.ByteString.Char8 as BSS -import Data.ByteString (ByteString) -import Data.JSTarget.AST (Name (..)) -import Data.ByteString.Builder - --- | Pretty-printing options -data PPOpts = PPOpts { - nameComments :: Bool, -- ^ Emit comments for externals? - externalAnnotation :: Bool, -- ^ Emit comments for names? - useIndentation :: Bool, -- ^ Should we indent at all? - indentStr :: Builder, -- ^ Indentation step. - useNewlines :: Bool, -- ^ Use line breaks? - useSpaces :: Bool, -- ^ Use spaces other than where necessary? - preserveNames :: Bool -- ^ Use STG names? - } - -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 - -> Builder - -> (NameSupply, Builder, a)} - -instance Monad PP where - PP m >>= f = PP $ \opts indentlvl ns b -> - case m opts indentlvl ns b of - (ns', b', x) -> unPP (f x) opts indentlvl ns' 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, - externalAnnotation = False, - useIndentation = False, - indentStr = " ", - useNewlines = False, - useSpaces = False, - preserveNames = False - } - --- | Print code using indentation, whitespace and newlines. -withPretty :: PPOpts -> PPOpts -withPretty opts = opts { - useIndentation = True, - indentStr = " ", - useNewlines = True, - useSpaces = True - } - --- | Annotate non-local, non-JS symbols with qualified names. -withAnnotations :: PPOpts -> PPOpts -withAnnotations opts = opts {nameComments = True} - --- | Annotate externals with /* EXTERNAL */ comment. -withExtAnnotation :: PPOpts -> PPOpts -withExtAnnotation opts = opts {externalAnnotation = True} - -withHSNames :: PPOpts -> PPOpts -withHSNames opts = opts {preserveNames = 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) - --- | 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 :: Pretty a => PPOpts -> a -> BS.ByteString -pretty opts ast = - case runPP opts (pp ast) of - (b, _) -> toLazyByteString b - --- | Run a pretty printer. -runPP :: PPOpts -> PP a -> (Builder, a) -runPP opts p = - case unPP p opts 0 emptyNS mempty of - (_, b, x) -> (b, x) - --- | Pretty-print a program and return the final name for its entry point. -prettyProg :: Pretty a => PPOpts -> Name -> a -> (Builder, Builder) -prettyProg opts mainSym ast = runPP opts $ do - pp ast - hsnames <- getOpt preserveNames - if hsnames - then return $ buildStgName mainSym - else buildFinalName <$> finalNameFor mainSym - --- | JS-mangled version of an internal name. -buildStgName :: Name -> Builder -buildStgName (Name n mq) = - byteString "$hs$" <> qual <> byteString (BSS.map mkjs n) - where - qual = case mq of - Just (_, m) -> byteString (BSS.map mkjs m) <> byteString "$" - _ -> mempty - mkjs c - | c >= 'a' && c <= 'z' = c - | c >= 'A' && c <= 'Z' = c - | c >= '0' && c <= '9' = c - | c == '$' = c - | otherwise = '_' - --- | Turn a FinalName into a Builder. -buildFinalName :: FinalName -> Builder -buildFinalName (FinalName 0) = - fromString "_0" -buildFinalName (FinalName fn) = - charUtf8 '_' <> 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 (charUtf8 (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 ByteString where - put = put . byteString -instance Buildable String where - put = put . stringUtf8 -instance Buildable Char where - put = put . charUtf8 -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 True = "true" - put False = "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 (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 deleted file mode 100644 --- a/src/Data/JSTarget/Print.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances, GADTs, OverloadedStrings, CPP #-} -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.Builder -import Control.Monad -import Data.Char -import Numeric (showHex) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.UTF8 as BS - -instance Pretty Var where - pp (Foreign name) = do - put name - doComment <- getOpt externalAnnotation - when doComment . put $ byteString "/* EXTERNAL */" - pp (Internal name@(Name _ _) comment _) = do - hsnames <- getOpt preserveNames - if hsnames - then put $ buildStgName name - else do - pp name - doComment <- getOpt nameComments - when doComment $ do - when (not $ BS.null comment) $ do - put $ byteString "/* " - put comment - put $ byteString " */" - -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 $ BS.toString s) .+. "\"" - where - fixQuotes ('\\':xs) = "\\\\" ++ fixQuotes xs - fixQuotes ('"':xs) = '\\':'"' : fixQuotes xs - fixQuotes ('\'':xs) = '\\':'\'' : fixQuotes xs - fixQuotes ('\r':xs) = '\\':'r' : fixQuotes xs - fixQuotes ('\n':xs) = '\\':'n' : fixQuotes xs - fixQuotes (x:xs) - | ord x <= 127 = x : fixQuotes xs - | otherwise = toHex x ++ fixQuotes xs - fixQuotes _ = [] - pp (LBool b) = put b - pp (LInt n) = put n - pp (LNull) = "null" - --- | Generate a Haskell \uXXXX escape sequence for a char if it's >127. -toHex :: Char -> String -toHex c = - case ord c of - n | n < 127 -> [c] - | otherwise -> "\\u" ++ exactlyFour (showHex (n `rem` 65536) "") - --- | Truncate and pad a string to exactly four characters. '0' is used for padding. -exactlyFour :: String -> String -exactlyFour s = - pad (4-len) $ drop (len-4) s - where - len = length s - pad 0 cs = cs - pad n cs = '0' : pad (n-1) cs - - --- | 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 (JSLit l) = - put l - pp (Not ex) = do - case neg ex of - Just ex' -> pp ex' - _ -> if expPrec (Not ex) > expPrec ex - then "!(" .+. pp ex .+. ")" - else "!" .+. pp ex - pp bop@(BinOp _ _ _) = - case norm bop of - BinOp op a b -> opParens op a b - ex -> pp ex - pp (Fun args body) = do - "function(" .+. ppList sep args .+. "){" .+. newl - indent $ pp body - ind .+. "}" - pp (Call _ call f args) = do - case call of - Normal True -> "B(" .+. normalCall .+. ")" - Normal False -> normalCall - Fast True -> "B(" .+. fastCall .+. ")" - Fast False -> fastCall - Method m -> - pp f .+. put (BS.cons '.' m) .+. "(" .+. ppList sep args .+. ")" - where - normalCall = "A(" .+. pp f .+. ",[" .+. ppList sep args .+. "])" - fastCall = ppCallFun f .+. "(" .+. ppList sep args .+. ")" - ppCallFun fun@(Fun _ _) = "(" .+. pp fun .+. ")" - ppCallFun fun = pp fun - pp e@(Index arr ix) = do - if expPrec e > expPrec arr - then "(" .+. pp arr .+. ")" - else pp arr - "[" .+. pp ix .+. "]" - pp (Arr exs) = do - "[" .+. ppList sep exs .+. "]" - pp (AssignEx l r) = do - pp l .+. sp .+. "=" .+. sp .+. pp r - pp e@(IfEx c th el) = do - if expPrec e > expPrec c - then "(" .+. pp c .+. ")" - else pp c - sp .+. "?" .+. sp .+. pp th .+. sp .+. ":" .+. sp .+. pp el - pp (Eval x) = do - "E(" .+. pp x .+. ")" - pp (Thunk True x) = do - "new T(function(){" .+. newl .+. indent (pp x) .+. ind .+. "})" - pp (Thunk False x) = do - "new T(function(){" .+. newl .+. indent (pp x) .+. ind .+. "},1)" - -instance Pretty (Var, Exp) where - pp (v, ex) = pp v .+. sp .+. "=" .+. sp .+. pp ex - -instance Pretty Bool where - pp True = "true" - pp False = "false" - --- | Print a series of NewVars at once, to avoid unnecessary "var" keywords. -ppAssigns :: Stm -> PP () -ppAssigns stm = do - line $ "var " .+. ppList ("," .+. newl .+. ind) 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 _ _ _ next -> finalStm next - Forever s' -> finalStm s' - _ -> return s - -instance Pretty Stm where - pp (Case cond def alts next) = do - prettyCase cond def alts - pp next - 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 (Stop) = do - return () - pp (Tailcall call) = do - line $ "return new F(function(){return " .+. pp call .+. ";});" - pp (ThunkRet ex) = do - line $ "return " .+. pp ex .+. ";" - -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 - (_, Stop) -> do - line $ "if(" .+. pp (neg' (test con)) .+. "){" - indent $ pp def - line "}" - (Stop, _) -> 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 - test (Lit (LBool True)) = cond - test (Lit (LBool False)) = Not cond - test (Lit (LNum 0)) = Not cond - test c = BinOp Eq cond c - neg' c = maybe (Not c) id (neg c) -prettyCase _ def [] = do - pp def -prettyCase cond def alts = do - 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 .+. ")" - _ -> parensR - parensL a .+. put (stringUtf8 $ show op) .+. bparens b - where - parensL x = if expPrec x < opPrec op - then "(" .+. pp x .+. ")" - else pp x - parensR x = if expPrec x <= opPrec op - then "(" .+. pp x .+. ")" - else pp x - --- | Normalize an operator expression by shifting parentheses to the left for --- all associative operators and eliminating comparisons with true/false. -norm :: Exp -> Exp -norm (BinOp op a (BinOp op' b c)) | op == op' && opIsAssoc op = - norm (BinOp op (BinOp op a b) c) -norm (BinOp Eq a (Lit (LBool True))) = norm a -norm (BinOp Eq (Lit (LBool True)) b) = norm b -norm (BinOp Eq a (Lit (LBool False))) = Not (norm a) -norm (BinOp Eq (Lit (LBool False)) b) = Not (norm b) -norm (BinOp Neq a (Lit (LBool True))) = Not (norm a) -norm (BinOp Neq (Lit (LBool True)) b) = Not (norm b) -norm (BinOp Neq a (Lit (LBool False))) = norm a -norm (BinOp Neq (Lit (LBool False)) b) = norm b -norm e = e diff --git a/src/Data/JSTarget/Traversal.hs b/src/Data/JSTarget/Traversal.hs deleted file mode 100644 --- a/src/Data/JSTarget/Traversal.hs +++ /dev/null @@ -1,344 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TupleSections, PatternGuards, BangPatterns #-} --- | Generic traversal of JSTarget AST types. -module Data.JSTarget.Traversal where -import Control.Applicative -import Control.Monad -import Control.Monad.Identity -import Data.JSTarget.AST - --- | AST nodes we'd like to fold and map over. -data ASTNode = Exp !Exp !Bool | Stm !Stm !Bool | Shared !Stm - -type TravM a = Identity a - -runTravM :: TravM a -> a -runTravM = runIdentity - -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 - {-# INLINE const' #-} - 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 = go - where - go acc ast - | tr acc $! Exp ast False = do - (acc', x) <- do - case ast of - v@(Var _) -> pure (acc, v) - l@(Lit _) -> pure (acc, l) - l@(JSLit _) -> pure (acc, l) - Not ex -> fmap Not <$> go acc ex - BinOp op a b -> do - (acc', a') <- go acc a - (acc'', b') <- go acc' b - return (acc'', BinOp op a' b') - Fun vs stm -> fmap (Fun vs) <$> foldMapJS tr fe fs acc stm - Call ar c f xs -> do - (acc', f') <- go acc f - (acc'', xs') <- foldMapJS tr fe fs acc' xs - return (acc'', Call ar c f' xs') - Index arr ix -> do - (acc', arr') <- go acc arr - (acc'', ix') <- go acc' ix - return (acc'', Index arr' ix') - Arr exs -> fmap Arr <$> foldMapJS tr fe fs acc exs - AssignEx l r -> do - (acc', l') <- go acc l - (acc'', r') <- go acc' r - return (acc'', AssignEx l' r') - IfEx c th el -> do - (acc', c') <- go acc c - (acc'', th') <- if tr acc (Exp th True) - then go acc' th - else return (acc', th) - (acc''', el') <- if tr acc (Exp el True) - then go acc'' el - else return (acc'', el) - return (acc''', IfEx c' th' el') - Eval x -> fmap Eval <$> go acc x - Thunk upd x -> fmap (Thunk upd) <$> foldMapJS tr fe fs acc x - fe acc' x - | otherwise = do - fe acc ast - - foldJS tr f = go - where - go acc ast - | tr acc $! expast = do - flip f expast =<< do - case ast of - Var _ -> return acc - Lit _ -> return acc - JSLit _ -> return acc - Not ex -> go acc ex - BinOp _ a b -> go acc a >>= flip go b - Fun _ stm -> foldJS tr f acc stm - Call _ _ fun xs -> go acc fun >>= flip (foldJS tr f) xs - Index arr ix -> go acc arr >>= flip go ix - Arr exs -> foldJS tr f acc exs - AssignEx l r -> go acc l >>= flip go r - IfEx c th el -> do - acc' <- go acc c - acc'' <- if tr acc $! Exp th True - then go acc' th - else return acc' - if tr acc $! Exp th True - then go acc'' el - else return acc'' - Eval ex -> go acc ex - Thunk _upd stm -> foldJS tr f acc stm - | otherwise = - f acc expast - where !expast = Exp ast False - -instance JSTrav Stm where - foldMapJS tr fe fs = go - where - go acc ast - | tr acc $! Stm ast False = do - (acc', x) <- do - case ast of - Case ex def as nxt -> do - (acc1, ex') <- foldMapJS tr fe fs acc ex - (acc2, def') <- go acc1 def - (acc3, as') <- foldMapJS tr fe fs acc2 as - (acc4, nxt') <- if tr acc $! Shared nxt - then go acc3 nxt - else return (acc3, nxt) - return (acc4, Case ex' def' as' nxt') - Assign lhs ex next -> do - (acc', lhs') <- foldMapJS tr fe fs acc lhs - (acc'', ex') <- foldMapJS tr fe fs acc' ex - (acc''', next') <- go acc'' next - return (acc''', Assign lhs' ex' next') - Forever stm -> fmap Forever <$> go acc stm - Return ex -> fmap Return <$> foldMapJS tr fe fs acc ex - Cont -> return (acc, ast) - Stop -> return (acc, ast) - Tailcall ex -> fmap Tailcall <$> foldMapJS tr fe fs acc ex - ThunkRet ex -> fmap ThunkRet <$> foldMapJS tr fe fs acc ex - fs acc' x - | otherwise = do - fs acc ast - - foldJS tr f = go - where - go acc ast - | tr acc stmast = do - flip f stmast =<< do - case ast of - Case ex def as nxt -> do - acc' <- foldJS tr f acc ex >>= flip go def - acc'' <- foldJS tr f acc' as - if tr acc $! Shared nxt - then go acc'' nxt - else return acc'' - Assign lhs ex next -> do - foldJS tr f acc lhs >>= flip (foldJS tr f) ex >>= flip go next - Forever stm -> foldJS tr f acc stm - Return ex -> foldJS tr f acc ex - Cont -> return acc - Stop -> return acc - Tailcall ex -> foldJS tr f acc ex - ThunkRet ex -> foldJS tr f acc ex - | otherwise = - f acc stmast - where !stmast = Stm ast False - -instance JSTrav (Exp, Stm) where - foldMapJS tr fe fs acc (ex, stm) = do - (acc', stm') <- if tr acc (Stm stm True) - then foldMapJS tr fe fs acc stm - else return (acc, stm) - (acc'', ex') <- if tr acc (Exp ex True) - then foldMapJS tr fe fs acc' ex - else return (acc', ex) - return (acc'', (ex', stm')) - foldJS tr f acc (ex, stm) = do - acc' <- if tr acc (Stm stm True) - then foldJS tr f acc stm - else return acc - if tr acc (Exp ex True) - then foldJS tr f acc' ex - else return acc' - -instance JSTrav LHS where - foldMapJS _ _ _ acc lhs@(NewVar _ _) = - return (acc, lhs) - foldMapJS t fe fs a (LhsExp r ex) = - fmap (LhsExp r) <$> foldMapJS t fe fs a ex - foldJS _ _ acc (NewVar _ _) = return acc - foldJS tr f acc (LhsExp _ ex) = foldJS tr f acc ex - --- | Returns the final statement of a line of statements. -finalStm :: Stm -> TravM Stm -finalStm = go - where - go (Case _ _ _ next) = go next - go (Forever s) = go s - go (Assign _ _ next) = go next - go s = return s - --- | Replace the final statement of the given AST with a new one, but only --- if matches the given predicate. -replaceFinalStm :: Stm -> (Stm -> Bool) -> Stm -> TravM Stm -replaceFinalStm new p = go - where - go (Case c d as next) = Case c d as <$> go next - go (Forever s) = Forever <$> go s - go (Assign l r next) = Assign l r <$> go next - go s = return $ if p s then new else s - --- | Returns statement's returned expression, if any. -finalExp :: Stm -> TravM (Maybe Exp) -finalExp stm = do - end <- finalStm stm - case end of - Return ex -> return $ Just ex - _ -> return Nothing - -class Pred a where - (.|.) :: a -> a -> a - (.&.) :: a -> a -> a - -instance Pred (a -> b -> Bool) where - {-# INLINE (.|.) #-} - {-# INLINE (.&.) #-} - 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 - {-# INLINE (.|.) #-} - {-# INLINE (.&.) #-} - p .|. q = \a -> p a || q a - p .&. q = \a -> p a && q a - --- | Thunks and explicit lambdas count as lambda abstractions. -{-# INLINE isLambda #-} -isLambda :: ASTNode -> Bool -isLambda = isThunk .|. isFun - -{-# INLINE isThunk #-} -isThunk :: ASTNode -> Bool -isThunk (Exp (Thunk _ _) _) = True -isThunk _ = False - -{-# INLINE isFun #-} -isFun :: ASTNode -> Bool -isFun (Exp (Fun _ _) _) = True -isFun _ = False - -{-# INLINE isLoop #-} -isLoop :: ASTNode -> Bool -isLoop (Stm (Forever _) _) = True -isLoop _ = False - -{-# INLINE isConditional #-} -isConditional :: ASTNode -> Bool -isConditional (Exp _ cond) = cond -isConditional (Stm _ cond) = cond -isConditional _ = False - -{-# INLINE isShared #-} -isShared :: ASTNode -> Bool -isShared (Shared _) = True -isShared _ = False - -{-# INLINE isSafeForInlining #-} -isSafeForInlining :: ASTNode -> Bool -isSafeForInlining = not <$> isFun .|. isLoop .|. isShared - --- | Counts occurrences. Use ints or something for a more exact count. -data Occs = Never | Once | Lots deriving (Eq, Show) - -instance Ord Occs where - {-# INLINE compare #-} - 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 - - Never - _ = Never - x - Never = x - Once - _ = Never - Lots - _ = Lots - - abs = id - - signum Never = Never - signum _ = Once - --- | 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 - --- | Replace all occurrences of an expression, without entering shared code --- paths. IO ordering is preserved even when entering lambdas thanks to --- State# RealWorld. -replaceExWithCount :: JSTrav ast - => (ASTNode -> Bool) -- ^ Which nodes to enter? - -> Exp -- ^ Expression to replace. - -> Exp -- ^ Replacement expression. - -> ast -- ^ AST to perform replacement on. - -> TravM (Int, ast) -- ^ New AST + count of replacements. -replaceExWithCount trav old new ast = - foldMapJS (const trav) rep (\count x -> return (count, x)) 0 ast - where - rep count ex - | ex == old = return (count+1, new) - | otherwise = return (count, ex) diff --git a/src/Haste.hs b/src/Haste.hs deleted file mode 100644 --- a/src/Haste.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Haste ( - module Linker, module Config, module CodeGen, - Module, writeModule, readModule) where -import Haste.Linker as Linker -import Haste.Config as Config -import Haste.Module -import Haste.CodeGen as CodeGen -import Data.JSTarget.AST (Module) diff --git a/src/Haste/AST.hs b/src/Haste/AST.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST.hs @@ -0,0 +1,17 @@ +-- | Haste's intermediate JavaScript representation. +module Haste.AST ( + module Constr, module Op, module Optimize, module Trav, module Opts, + PPOpts (..), pretty, runPP, prettyProg, + Arity, Comment, Name (..), Var (..), LHS, Call, + Lit, Exp, Stm, Alt, Module (..), + foreignModule, moduleOf, pkgOf, blackHole, blackHoleVar, zeroObject, merge + ) where +import Haste.AST.Syntax +import Haste.AST.Op as Op +import Haste.AST.Optimize as Optimize +import Haste.AST.Constructors as Constr +import Haste.AST.PP (pretty, runPP, prettyProg) +import Haste.AST.PP.Opts as Opts +import Haste.AST.Print as Print () +import Haste.AST.Binary () +import Haste.AST.Traversal as Trav diff --git a/src/Haste/AST/Binary.hs b/src/Haste/AST/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST/Binary.hs @@ -0,0 +1,159 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Binary instances for JSTarget types. +module Haste.AST.Binary () where +import Prelude hiding (LT, GT) +import Data.Binary +import Data.Array +import Control.Applicative +import Haste.AST.Syntax +import Haste.AST.Op + +instance Binary Module where + put (Module pkgid name deps defs) = + put pkgid >> put name >> put deps >> put defs + get = Module <$> get <*> get <*> get <*> get + +instance Binary Var where + put (Foreign str) = + putWord8 0 >> put str + put (Internal name comment knownloc) = + putWord8 1 >> put name >> put comment >> put knownloc + + get = do + which <- getWord8 + case which of + 0 -> Foreign <$> get + 1 -> Internal <$> get <*> get <*> get + +instance Binary LHS where + put (NewVar r v) = putWord8 0 >> put r >> put v + put (LhsExp r e) = putWord8 1 >> put r >> put e + + get = getWord8 >>= ([NewVar <$> get <*> get, + LhsExp <$> get <*> get] !!) . fromIntegral + +instance Binary Call where + put (Normal tr) = putWord8 0 >> put tr + put (Fast tr) = putWord8 1 >> put tr + put (Method m) = putWord8 2 >> put m + + get = do + tag <- fromIntegral <$> getWord8 + [Normal <$> get, Fast <$> get,Method <$> get] !! tag + +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 (JSLit l) = putWord8 2 >> put l + put (Not ex) = putWord8 3 >> put ex + put (BinOp op a b) = putWord8 4 >> put op >> put a >> put b + put (Fun as body) = putWord8 5 >> put as >> put body + put (Call a c f xs) = putWord8 6 >> put a >> put c >> put f >> put xs + put (Index arr ix) = putWord8 7 >> put arr >> put ix + put (Arr exs) = putWord8 8 >> put exs + put (AssignEx l r) = putWord8 9 >> put l >> put r + put (IfEx c th el) = putWord8 10 >> put c >> put th >> put el + put (Eval x) = putWord8 11 >> put x + put (Thunk upd x) = putWord8 12 >> put upd >> put x + put (Member o m) = putWord8 13 >> put o >> put m + put (Obj xs) = putWord8 14 >> put xs + + get = do + tag <- getWord8 + case tag of + 0 -> Var <$> get + 1 -> Lit <$> get + 2 -> JSLit <$> get + 3 -> Not <$> get + 4 -> BinOp <$> get <*> get <*> get + 5 -> Fun <$> get <*> get + 6 -> Call <$> get <*> get <*> get <*> get + 7 -> Index <$> get <*> get + 8 -> Arr <$> get + 9 -> AssignEx <$> get <*> get + 10 -> IfEx <$> get <*> get <*> get + 11 -> Eval <$> get + 12 -> Thunk <$> get <*> get + 13 -> Member <$> get <*> get + 14 -> Obj <$> 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 (Stop) = + putWord8 5 + put (Tailcall ex) = + putWord8 6 >> put ex + put (ThunkRet ex) = + putWord8 7 >> put ex + + 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 -> pure Stop + 6 -> Tailcall <$> get + 7 -> ThunkRet <$> get + 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 StrictEq = putWord8 8 + put Neq = putWord8 9 + put StrictNeq = putWord8 10 + put LT = putWord8 11 + put GT = putWord8 12 + put LTE = putWord8 13 + put GTE = putWord8 14 + put Shl = putWord8 15 + put ShrL = putWord8 16 + put ShrA = putWord8 17 + put BitAnd = putWord8 18 + put BitOr = putWord8 19 + put BitXor = putWord8 20 + + get = (opTbl !) <$> getWord8 + +instance Binary Name where + put (Name name owner) = put name >> put owner + get = Name <$> 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, StrictEq, Neq, StrictNeq, + LT, GT, LTE, GTE, Shl, ShrL, ShrA, BitAnd, BitOr, BitXor] diff --git a/src/Haste/AST/Constructors.hs b/src/Haste/AST/Constructors.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST/Constructors.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE FlexibleInstances, TupleSections, CPP, OverloadedStrings #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif +-- | Smart constructors for Haste's AST. +module Haste.AST.Constructors where +import Haste.AST.Syntax +import Haste.AST.Op +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.UTF8 as BS + +-- | Literal types. +class Literal a where + lit :: a -> Exp + +instance Literal Lit where + lit = Lit + +instance Literal Double where + lit = lit . LNum + +instance Literal Integer where + lit = lit . LInt + +instance Literal Bool where + lit = lit . LBool + +instance Literal BS.ByteString where + lit = lit . LStr + +instance Literal [Char] where + lit = lit . BS.fromString + +#if __GLASGOW_HASKELL__ < 710 +instance Literal a => Literal [a] where +#else +instance {-# OVERLAPPABLE #-} Literal a => Literal [a] where +#endif + lit = Arr . map lit + +instance Literal Exp where + lit = id + +instance Literal Var where + lit = Var + +litN :: Double -> Exp +litN = lit + +litS :: BS.ByteString -> Exp +litS = lit + +-- | Create a foreign variable. Foreign vars will not be subject to any name +-- mangling. +foreignVar :: BS.ByteString -> Var +foreignVar = Foreign + +-- | A regular, internal variable. Subject to name mangling. +internalVar :: Name -> BS.ByteString -> Var +internalVar n c = Internal n c False + +-- | A variable serving as a known location, to store return values from +-- expressions that get compiled into statements. +knownLocation :: Name -> BS.ByteString -> Var +knownLocation n c = Internal n c True + +-- | Create a name, qualified or not. +name :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) -> Name +name = Name + +-- | A variable expression, for convenience. +var :: Name -> BS.ByteString -> Exp +var n comment = Var $ internalVar n comment + +-- | Turn a Var into an expression. +varExp :: Var -> Exp +varExp = Var + +-- | Call to a native method on an object. Always saturated. +callMethod :: Exp -> BS.ByteString -> [Exp] -> Exp +callMethod obj meth args = Call 0 (Method meth) obj args + +-- | Foreign function call. Always saturated, never trampolines. +callForeign :: BS.ByteString -> [Exp] -> Exp +callForeign f = Call 0 (Fast False) (Var $ foreignVar f) + +-- | A normal function call. May be unsaturated. A saturated call is always +-- turned into a fast call. +call :: Arity -> Exp -> [Exp] -> Exp +call arity f xs = foldApp $ Call (arity - length xs) (Normal True) f xs + +callSaturated :: Exp -> [Exp] -> Exp +callSaturated f xs = Call 0 (Fast True) f 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 tramp) (Call _ (Normal _) f args) args') = + Call arity (Normal tramp) (foldApp f) (args ++ args') +foldApp (Call 0 (Normal tramp) f args) = + Call 0 (Fast tramp) f args +foldApp (Call arity (Normal tramp) f args) | arity > 0 = + Fun newargs $ Return + $ Call arity (Fast tramp) f (args ++ map Var newargs) + where + newargs = newVars "_fa_" arity +foldApp ex = + ex + +-- | Introduce n new vars. +newVars :: String -> Int -> [Var] +newVars prefix n = + map nv [1..n] + where + nv i = Internal (Name (BS.fromString $ prefix++show i) Nothing) "" False + +-- | Create a thunk. +thunk :: Bool -> Stm -> Exp +thunk = Thunk + +-- | Evaluate an expression that may or may not be a thunk. +eval :: Exp -> Exp +eval ex + | definitelyNotThunk ex = ex + | otherwise = Eval ex + +-- | Create a tail call. +tailcall :: Exp -> Stm +tailcall = Tailcall + +-- | A binary operator. +binOp :: BinOp -> Exp -> Exp -> Exp +binOp = BinOp + +-- | Negate an expression. +not_ :: Exp -> Exp +not_ = Not + +-- | Index into an array. +index :: Exp -> Exp -> Exp +index = Index + +-- | Create a function. +fun :: [Var] -> Stm -> Exp +fun = Fun + +-- | Create an array of expressions. +array :: [Exp] -> Exp +array = Arr + +-- | 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_ :: Exp -> (Stm -> Stm) -> [(Exp, Stm -> Stm)] -> Stm -> Stm +case_ ex def alts = Case ex (def stop) (map (\(e, s) -> (e, s stop)) alts) + +-- | Return from a function. +ret :: Exp -> Stm +ret = Return + +-- | Return from a thunk. +thunkRet :: Exp -> Stm +thunkRet = ThunkRet + +-- | Create a new var with a new value. +newVar :: Reorderable -> Var -> Exp -> Stm -> Stm +newVar r lhs = Assign (NewVar r lhs) + +-- | Reuse an old variable. +assignVar :: Reorderable -> Var -> Exp -> Stm -> Stm +assignVar r lhs = Assign (LhsExp r (Var lhs)) + +-- | Assignment without var. Performed for the side effect, so never +-- reorderable. +sideEffectingAssign :: Exp -> Exp -> Stm -> Stm +sideEffectingAssign lhs = Assign (LhsExp False lhs) + +-- | Assignment expression. +assignEx :: Exp -> Exp -> Exp +assignEx = AssignEx + +-- | Terminate a statement without doing anything at all. +stop :: Stm +stop = Stop + +-- | Data constructor application. +conApp :: Exp -> [Exp] -> Exp +conApp tag = Obj . ((dataConTagField, tag) :) . zip dataConFieldNames + +-- | Get the data constructor tag of the given algebraic value. +getTag :: Exp -> Exp +getTag e = e `select` dataConTagField + +-- | Get the @n@th field of the given algebraic value. +getField :: Exp -> Int -> Exp +getField e n = e `select` (dataConFieldNames !! n) + +-- | Get a member from an object. +select :: Exp -> BS.ByteString -> Exp +select = Member diff --git a/src/Haste/AST/FlowAnalysis.hs b/src/Haste/AST/FlowAnalysis.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST/FlowAnalysis.hs @@ -0,0 +1,170 @@ +-- | Basic data flow analysis over the Haste AST. +module Haste.AST.FlowAnalysis ( + Strict (..), VarInfo (..), InfoMap, ArgMap, + mkVarInfo, nullInfo, mergeVarInfos, findVarInfos + ) where +import Haste.AST.Syntax +import Control.Monad.State +import Data.List (foldl', sort, group) +import qualified Data.Set as S +import qualified Data.Map as M + +data Strict = Strict | Unknown + deriving (Eq, Show) + +data VarInfo = VarInfo { + -- | Is this var always strict? + varStrict :: Strict, + + -- | Does this var always have the same, statically known, arity? + -- @Nothing@, if var is not a function. + varArity :: Maybe Int, + + -- | What are the sources of this var? I.e. for each occurrence where the + -- var is the LHS of an assignment or substitution (including function + -- call), add the RHS to this list. + varAlias :: [Var] + } deriving (Eq, Show) + +mkVarInfo :: Strict -> Maybe Int -> VarInfo +mkVarInfo s ar = VarInfo s ar [] + +type InfoMap = M.Map Var VarInfo +type ArgMap = M.Map Var [Var] + +nullInfo :: VarInfo +nullInfo = VarInfo Unknown Nothing [] + +-- | Merge two var infos. The aliases of the infos are simply concatenated +-- and filtered for duplicates. For concrete information, if the two infos +-- disagree on any field, that field becomes unknown. +mergeVarInfos :: VarInfo -> VarInfo -> VarInfo +mergeVarInfos a b = VarInfo strict' arity' (varAlias a `merge` varAlias b) + where + strict' + | varStrict a == varStrict b = varStrict a + | otherwise = Unknown + arity' + | varArity a == varArity b = varArity a + | otherwise = Nothing + merge as bs = map head . group . sort $ as ++ bs + +-- | Merge the infos of a var with that of all of its aliases. +resolveVarInfo :: InfoMap -> Var -> Maybe VarInfo +resolveVarInfo m var = go (S.singleton var) var + where + go seen v = do + nfo <- M.lookup v m + let xs' = filter (not . (`S.member` seen)) (varAlias nfo) + seen' = foldl' (flip S.insert) seen xs' + nfos <- mapM (go seen') xs' + case foldl' mergeVarInfos (nfo {varAlias = xs'}) nfos of + VarInfo Unknown Nothing _ -> Nothing + nfo' -> return nfo' + +type EvalM = State InfoMap + +-- | Figure out as much statically known information as possible about all +-- vars in a program. The returned map will be collapsed so that recursive +-- lookups are not necessary, and the 'varAlias' field of each info will +-- be empty. +-- +-- TODO: track return values, tail call status +findVarInfos :: ArgMap -> Stm -> InfoMap +findVarInfos argmap = mergeAll . snd . flip runState M.empty . goS + where + mergeAll m = M.foldWithKey resolve m m + + resolve v _ m = + case resolveVarInfo m v of + Just nfo -> M.insert v (nfo {varAlias = []}) m + _ -> m + + goS Stop = return () + goS Cont = return () + goS (Forever s) = goS s + goS (Case c d as next) = do + goE c + goS d + mapM_ (\(e, s) -> goE e >> goS s) as + goS next + goS (Assign (NewVar _ v) rhs next) = handleAssign v rhs >> goS next + goS (Assign (LhsExp _ (Var v)) rhs next) = handleAssign v rhs >> goS next + goS (Assign (LhsExp _ lhs) rhs next) = goE lhs >> goE rhs >> goS next + goS (Return ex) = goE ex + goS (ThunkRet ex) = goE ex + goS (Tailcall ex) = goE ex + + handleAssign v (Var v') = v `dependsOn` v' + handleAssign v (Eval (Var v')) = v `dependsOn` v' + handleAssign v (Fun args body) = do + v `hasInfo` mkVarInfo Strict (Just $ length args) + goS body + handleAssign v (Lit _) = v `hasInfo` mkVarInfo Strict Nothing + handleAssign v (JSLit _) = v `hasInfo` mkVarInfo Strict Nothing + handleAssign v rhs = v `hasInfo` nullInfo >> goE rhs + + -- If a function is ever stored anywhere except as a pure alias, we must + -- immediately stop assuming things about it, since we now have no idea + -- where it may be called. If it is not stored, we know that all calls to + -- it will be direct, so it is safe to assume things about its arguments + -- based on our static analysis. + -- To be safe - but overly conservative - we set the + -- info of any arguments of each function aliased by a var that occurs + -- outside a permitted context (function call or synonymous assignment) + -- to nullInfo. + goE (Var v) = setArgsOf v nullInfo (S.singleton v) + goE (Lit _) = return () + goE (JSLit _) = return () + goE (Not ex) = goE ex + goE (BinOp _ a b) = goE a >> goE b + goE (Fun _ body) = goS body + goE (Call _ _ (Var f) xs) = handleCall f xs + goE (Call _ _ (Fun as b) xs) = handleArgs as xs >> goS b + goE (Call _ _ f xs) = mapM_ goE (f:xs) + goE (Index x ix) = goE x >> goE ix + goE (Arr xs) = mapM_ goE xs + goE (Member x _) = goE x + goE (Obj xs) = mapM_ goE (map snd xs) + goE (AssignEx (Var v) rhs) = handleAssign v rhs + goE (AssignEx lhs rhs) = goE lhs >> goE rhs + goE (IfEx c l r) = mapM_ goE [c, l, r] + goE (Eval ex) = goE ex + goE (Thunk _ body) = goS body + + handleArgs as xs = sequence_ (zipWith handleAssign as xs) + + handleCall f argexs = + case M.lookup f argmap of + Just argvars -> handleArgs argvars argexs + _ -> return () + + -- Finds the functions (if any) aliased by v and sets the varinfo of their + -- arguments to @nfo@. + setArgsOf v nfo seen = do + case M.lookup v argmap of + Just args -> mapM_ (`hasInfo` nullInfo) args + _ -> do + nfos <- get + case M.lookup v nfos of + Nothing -> return () + Just nfo' -> do + let aliases = filter (not . (`S.member` seen)) (varAlias nfo') + seen' = foldl' (flip S.insert) seen aliases + mapM_ (\v' -> setArgsOf v' nfo seen') aliases + +hasInfo :: Var -> VarInfo -> EvalM () +hasInfo v nfo = do + nfos <- get + put $ M.alter upd v nfos + where + upd (Just nfo') = Just $ mergeVarInfos nfo nfo' + upd _ = Just nfo + +dependsOn :: Var -> Var -> EvalM () +dependsOn v v' = do + nfos <- get + put $ M.alter upd v nfos + where + upd (Just nfo) = Just $ nfo {varAlias = v' : varAlias nfo} + upd _ = Just $ nullInfo {varAlias = [v']} diff --git a/src/Haste/AST/Op.hs b/src/Haste/AST/Op.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST/Op.hs @@ -0,0 +1,86 @@ +-- | Binary operations for the Haste AST. +module Haste.AST.Op where +import Prelude hiding (GT, LT) + +data BinOp + = Add + | Mul + | Sub + | Div + | Mod + | And + | Or + | Eq + | StrictEq + | Neq + | StrictNeq + | 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 StrictEq = "===" + show Neq = "!=" + show StrictNeq = "!==" + 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 StrictEq = 30 +opPrec Neq = 30 +opPrec StrictNeq = 30 +opPrec BitAnd = 25 +opPrec BitXor = 24 +opPrec BitOr = 23 +opPrec And = 20 +opPrec Or = 10 + +-- | Is the given operator associative? +opIsAssoc :: BinOp -> Bool +opIsAssoc Mul = True +opIsAssoc Add = True +opIsAssoc BitAnd = True +opIsAssoc BitOr = True +opIsAssoc BitXor = True +opIsAssoc And = True +opIsAssoc Or = True +opIsAssoc _ = False diff --git a/src/Haste/AST/Optimize.hs b/src/Haste/AST/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST/Optimize.hs @@ -0,0 +1,849 @@ +{-# LANGUAGE PatternGuards, TupleSections, DoAndIfThenElse, OverloadedStrings #-} +-- | Optimizations over the JSTarget AST. +module Haste.AST.Optimize ( + optimizeFun, tryTernary, topLevelInline + ) where +import Haste.AST.Syntax +import Haste.AST.Op +import Haste.AST.FlowAnalysis +import Haste.AST.Traversal +import Haste.Config +import Control.Applicative +import Control.Monad +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.ByteString.Char8 as BS + +-- | Turn tail recursion into loops. +fixTailCalls :: Var -> Exp -> TravM Exp +fixTailCalls fun ast = do + ast' <- assignToSubst ast >>= tailLoopify fun + mapJS (const True) pure loopify ast' + where + loopify (Assign lhs@(NewVar _ f) body next) = + Assign lhs <$> (assignToSubst body >>= tailLoopify f) <*> pure next + loopify stm = + return stm + +-- | Apply the given optimization when enabled by the config. +optWhen :: Bool -> (a -> TravM a) -> a -> TravM a +optWhen doit opt + | doit = opt + | otherwise = pure + +-- TODO: tryTernary may inline calls that would otherwise be in tail position +-- which is something we'd really like to avoid. +optimizeFun :: Config -> Var -> Exp -> Exp +optimizeFun c f ast = + runTravM $ do + shrinkCase ast + >>= inlineAssigns + >>= optimizeArrays + >>= inlineReturns + >>= zapJSStringConversions + >>= optimizeThunks + >>= optimizeArrays + >>= optWhen (enableTailLoops c) (fixTailCalls f) + >>= inlineShortJumpTailcall + >>= optWhen (enableProperTailcalls c) trampoline + >>= ifReturnToTernary + >>= smallStepInline + >>= optWhen (inlineJSPrim c) inlineJSPrimitives + >>= mapJS (const True) pure (pure . removeNonsenseAssigns) + +topLevelInline :: Config -> Stm -> Stm +topLevelInline c ast = + runTravM $ do + pure ast + >>= unevalLits + >>= inlineIntoEval + >>= inlineAssigns + >>= optimizeArrays + >>= optimizeThunks + >>= smallStepInline + >>= optimizeArrays + >>= zapJSStringConversions + >>= optWhen (inlineJSPrim c) inlineJSPrimitives + >>= removeUselessEvals + >>= inlineAssigns + >>= smallStepInline + >>= inlineAssigns + >>= optWhen (detrampolineThreshold c > 0) + (unTrampoline $ detrampolineThreshold c) + >>= inlineLiteralFunCalls + >>= optWhen (flowAnalysisOpts c) flowOpts + + +-- | Attempt to turn two case branches into a ternary operator expression. +tryTernary :: Var + -> Exp + -> Exp + -> (Stm -> Stm) + -> [(Exp, Stm -> Stm)] + -> Maybe Exp +tryTernary self scrut retEx def [(m, alt)] = + runTravM opt + where + selfOccurs (Exp (Var v) _) = v == self + selfOccurs _ = False + def' = def $ Return retEx + alt' = alt $ Return retEx + 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'' <- inlineAssigns def' + alt'' <- inlineAssigns 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 scrut m) th el + _ -> + return Nothing +tryTernary _ _ _ _ _ = + Nothing + +-- | Remove bogus assignments of the form @literal = exp@ and @_ = _@, +-- which may arise from other optimizations. +removeNonsenseAssigns :: Stm -> Stm +removeNonsenseAssigns (Assign (LhsExp _ (Lit _)) _ next) = next +removeNonsenseAssigns (Assign (LhsExp _ a) b next) | a == b = next +removeNonsenseAssigns (Assign (NewVar _ a) (Var b) next) | a == b = next +removeNonsenseAssigns stm = stm + +-- | 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 + +-- | 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 => ast -> TravM ast +inlineAssigns ast = do + inlinable <- countVarOccs ast + mapJS (const True) return (inl inlinable) ast + where + -- Assume that an assignment that is never used is actually there for a + -- good reason and thus not inlinable. + isSafe i v + | Just Once <- M.lookup v i = True + | otherwise = False + + atLeastOnce i v + | Just occs <- M.lookup v i = occs > Never + | otherwise = False + + isJSLit (Exp (JSLit {}) _) = True + isJSLit _ = False + + isVar v (Exp (Var v') _) = v == v' + isVar _ _ = False + + isWritten v (Exp (AssignEx (Var v') _) _) = v == v' + isWritten v (Stm (Assign (LhsExp _ (Var v')) _ _) _) = v == v' + isWritten _ _ = False + + -- It's OK to inline lambda-likes into anything that's not a loop or a + -- function (thunks are OK because they only get evaluated once). + goodInlineTgt = not <$> isLoop .|. isFun + + -- Only inline safe-to-reorder vars - if a var is ever assigned to, it is + -- insanely unsafe to inline it. + inl safe keep@(Assign (NewVar True v) rhs next) = do + written <- occurrences (const True) (isWritten v) next + case rhs of + _ | written /= Never -> do + return keep + -- String lits: inline if used exactly once to avoid blowing up code size + l@(Lit (LStr _)) | isSafe safe v -> do + replaceEx (const True) (Var v) l next + + -- Other lits: inline if used at least once + l@(Lit _) | atLeastOnce safe v -> do + occs <- occurrences (const True) (isVar v) next + if occs > Never + then replaceEx (const True) (Var v) l next + else return keep + + -- Variables: inline if used at least once + v'@(Var {}) | atLeastOnce safe v -> do + occs <- occurrences (const True) (isVar v) next + if occs > Never + then replaceEx (const True) (Var v) v' next + else return keep + + -- Everything else: inline if only used once and doesn't contain + -- lambda-likes. Lambda-likes may *never* be inlined as they may be + -- referred to in a *previous* binding and thus be recursive without + -- us knowing. We could fix this if we collected information about + -- lambda dependencies properly before starting any inlining, + -- if the lambda-like occurs exactly once, and this occurrence is not + -- in a lambda or a loop.but for now we disallow it. + ex | isSafe safe v -> do + lambdaoccs <- occurrences (const True) (isLambda .|. isJSLit) ex + recursive <- occurrences (const True) (isVar v) ex + case (lambdaoccs, recursive) of + (Never, Never) -> do + (reps, next') <- replaceExWithCount (const True) (Var v) ex next + if reps == 1 + then return next' + else return keep + (Once, Never) -> do + -- If we only made a single replacement in a good inline target, + -- then we know that everything is OK. If not, we accidentally + -- inlined into a bad code block, so we discard the result. + (reps, next') <- replaceExWithCount goodInlineTgt (Var v) ex next + if reps == 1 + then return next' + else return keep + _ -> do + pure keep + _ -> do + pure keep + inl _ keep = do + pure keep + +-- | Remove an occurrence of @ex = E(ex)@ or @lit = ex@. +-- Only call this for @ex@ which are guaranteed to never be thunks. +removeUpdate :: (Var -> Bool) -> Stm -> Stm +removeUpdate p stm@(Assign _ _ next) | isEvalUpd p stm = next +removeUpdate _ stm = stm + +-- | Inline function calls of the form @return (function(as){body})(xs)@. +-- TODO: 'inlineShortJumpTailcall' performs the same functionality for +-- named local tail calls - merge? +inlineLiteralFunCalls :: JSTrav ast => ast -> TravM ast +inlineLiteralFunCalls ast = do + mapJS (const True) pure (pure . inline) ast + where + inline s@(Return (Call _ (Fast False) (Fun as body) xs)) = + maybe s id (zipAssign (map (NewVar True) as) xs body) + inline s@(ThunkRet (Call _ (Fast False) (Fun as body) xs)) = + maybe s id (zipAssign (map (NewVar True) as) xs body) + inline s = s + +-- | Turn the common pattern @var x = e ; x = E(x)@ into @var x = E(e)@. +-- should run *after* 'unevalLits'. +inlineIntoEval :: JSTrav ast => ast -> TravM ast +inlineIntoEval ast = do + mapJS (const True) pure (pure . inline) ast + where + inline (Assign l@(NewVar _ v) r s@(Assign _ _ next)) + | isEvalUpd (== v) s = Assign l (Eval r) next + inline stm = stm + +isEvalUpd :: (Var -> Bool) -> Stm -> Bool +isEvalUpd p (Assign (LhsExp _ (Var v)) (Eval (Var v')) _) = p v && v == v' +isEvalUpd _ _ = False + +-- | Turn if(foo) {return bar;} else {return baz;} into return foo ? bar : baz. +ifReturnToTernary :: JSTrav ast => ast -> TravM ast +ifReturnToTernary ast = do + mapJS (const True) return opt ast + where + opt (Case cond (Return el) [(ex, Return th)] _) = + pure $ Return $ IfEx (BinOp Eq cond ex) th el + opt stm = + pure stm + +-- | Turn occurrences of @[a,b][1]@ or @{... x:b ...}.b@ into b. +optimizeArrays :: JSTrav ast => ast -> TravM ast +optimizeArrays ast = + mapJS (const True) inlEx return ast + where + inlEx (Index (Arr xs) (Lit (LNum n))) = + return $ xs !! truncate n + inlEx (Member (Obj xs) key) = + case lookup key xs of + Just x -> return x + _ -> error $ "Bad object literal deref: member " ++ show key + ++ " doesn't exist!" + inlEx x = + return x + +-- | Remove calls to E() where we know for sure the argument is already +-- evaluated. +removeUselessEvals :: JSTrav ast => ast -> TravM ast +removeUselessEvals ast = do + mapJS (const True) return opt ast + where + opt (Assign lhs@(NewVar _ l) rhs next) = do + Assign lhs rhs <$> case rhs of + Eval r@(Var _) -> removeEval (Var l) next >>= removeEval r + _ | isHNF rhs -> removeEval (Var l) next + | otherwise -> return next + opt stm = do + return stm + + isHNF (Lit {}) = True + isHNF (JSLit {}) = True + isHNF (Not {}) = True + isHNF (BinOp {}) = True + isHNF (Fun {}) = True + isHNF (Arr {}) = True + isHNF (Eval {}) = True + isHNF _ = False + + removeEval x = replaceEx (const True) (Eval x) x + +-- | Turn toJSStr(unCStr(x)) into x, since rewrite rules absolutely refuse +-- to work with unpackCString#. +-- Also turn T(unCStr(x)) into unCStr(x) whenever x is a literal, since +-- unCStr is evaluated lazily anyway. +zapJSStringConversions :: JSTrav ast => ast -> TravM ast +zapJSStringConversions ast = + mapJS (const True) opt return ast + where + opt (Call _ _ (Var (Foreign "toJSStr")) [ + Call _ _ (Var (Foreign "unCStr")) [x]]) = + return x + opt (Call _ _ (Var (Foreign "toJSStr")) [ + Eval (Call _ _ (Var (Foreign "unCStr")) [x])]) = + return x + opt (Thunk _ (Return x@(Call _ _ (Var (Foreign "unCStr")) [Lit _]))) = + return x + opt x = + return x + +-- | Optimize thunks in the following ways: +-- 1. A(thunk(return f), xs) +-- => A(f, xs) +-- 2. thunk(x@(JSLit s)) | s is a JS function object or marked eager +-- => x +-- 3. thunk(x@(Lit _)) +-- => x +-- 4. E(thunk(return x)) +-- => x +-- 5. E(x) | x is guaranteed to not be a thunk +-- => x +-- +-- Note that #2 depends on the invariant of 'JSLit': a JS literal must not +-- perform side effects or significant computation. +optimizeThunks :: JSTrav ast => ast -> TravM ast +optimizeThunks ast = + mapJS (const True) optEx return ast + where + optEx (Eval x) + | Just x' <- fromThunkEx x = return x' + | definitelyNotThunk x = return x + optEx ex@(Thunk _ _) + | Just l@(JSLit s) <- fromThunkEx ex = + case maybeExtractStrict s of + Just s' -> return $ JSLit s' + _ | isJSFunDecl s -> return l + | otherwise -> return ex + optEx ex@(Thunk _ _) + | Just l@(Lit _) <- fromThunkEx ex = return l + optEx (Call arity calltype f as) + | Just f' <- fromThunkEx f = return $ Call arity calltype f' as + optEx ex = return ex + +maybeExtractStrict :: BS.ByteString -> Maybe BS.ByteString +maybeExtractStrict js + | "__strict(" `BS.isPrefixOf` js && ")" `BS.isSuffixOf` js = + Just $ BS.init $ BS.drop 9 js + | otherwise = + Nothing + +-- | Conservatively approximate whether a given JS literal is a function +-- declaration or not. +-- +-- TODO: proper parsing here. +isJSFunDecl :: BS.ByteString -> Bool +isJSFunDecl s + | "function(" `BS.isPrefixOf` s && "}" `BS.isSuffixOf` s = True + | "(function(" `BS.isPrefixOf` s && ")" `BS.isSuffixOf` s = True + | otherwise = False + +-- | Unpack the given expression if it's a thunk. +fromThunk :: Exp -> Maybe Stm +fromThunk (Thunk _ body) = Just body +fromThunk _ = Nothing + +-- | Unpack the given expression if it's a thunk without internal bindings. +fromThunkEx :: Exp -> Maybe Exp +fromThunkEx ex = + case fromThunk ex of + Just (Return ex') -> Just ex' + Just (ThunkRet ex') -> Just ex' + _ -> Nothing + +-- | Count the occurrences of all variables in an AST. +countVarOccs :: JSTrav ast => ast -> TravM (M.Map Var Occs) +countVarOccs ast = do + foldJS (\_ _->True) countOccs (M.empty) ast + where + updVar (Just occs) = Just (occs+Once) + updVar _ = Just Once + updVarAss (Just o) = Just o + updVarAss _ = Just Never + + {-# INLINE countOccs #-} + 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 (Stm (Assign (LhsExp True (Var v)) _ _) _) = + pure (M.alter updVarAss v m) + countOccs m _ = + pure m + +-- | May the given expression ever tailcall? +-- TODO: +-- Be slightly smarter about handling locally defined functions; always +-- counting a tailcall from a local as a tailcall from the containing +-- function seems a bit too restrictive. On the other hand, this makes +-- only a very slight difference in the number of unnecessary tailcalls +-- eliminated. +mayTailcall :: JSTrav ast => ast -> TravM Bool +mayTailcall ast = do + foldJS enter countTCs False ast + where + enter True _ = False + enter _ (Exp (Thunk _ _) _) = False + enter _ (Exp (Fun _ _) _) = False + enter _ _ = True + countTCs _ (Stm (Tailcall _) _) = return True + countTCs acc _ = return acc + +-- | Gather a map of all symbols which we know will never make tail calls. +-- All calls to functions in this set can then safely be de-trampolined. +gatherNonTailcalling :: Stm -> TravM (S.Set Var) +gatherNonTailcalling stm = do + foldJS (\_ _ -> True) countTCs S.empty stm + where + countTCs s (Exp (Var v@(Foreign _)) _) = do + return $ S.insert v s + countTCs s (Stm (Assign (NewVar _ v) (JSLit {}) _) _) = do + return $ S.insert v s + countTCs s (Stm (Assign (NewVar _ v) (Fun _ body) _) _) = do + tc <- mayTailcall body + return $ if not tc then S.insert v s else s + countTCs s (Stm (Assign (LhsExp True (Var v)) (Fun _ body) _) _) = do + tc <- mayTailcall body + return $ if not tc then S.insert v s else s + countTCs s _ = do + return s + +-- | Remove trampolines wherever possible. +-- The trampoline machinery has some overhead; two extra activation records +-- on the stack for a single, non-tailcalling function, to be precise. +-- We observe that bouncing a function that is guaranteed to never tailcall +-- is a waste of resources, so we can remove those bounces. +-- Additionally, tailcalling a function which is guaranteed to not tailcall +-- in turn is wasteful (see above comment about overhead), so we can +-- eliminate any such function. +-- Since the tailcalling machinery grows the stack by a total of three +-- activation records for an arbitrary string of tailcalling functions, +-- we can apply this procedure recursively three times and still be +-- guaranteed to use no more stack frames than we would have without this +-- optimization. +-- +-- Note that we can only do this for fast calls, as we need to be able to +-- know exactly what function is actually called upon saturated application. +unTrampoline :: Int -> Stm -> TravM Stm +unTrampoline 0 s = pure s +unTrampoline n s = do + ntcs <- gatherNonTailcalling s + mapJS (const True) (unTr ntcs) (unTC ntcs) s >>= unTrampoline (n-1) + where + unTr ntcs (Call ar (Fast True) f@(Var v) xs) + | v `S.member` ntcs = + return $ Call ar (Fast False) f xs + unTr _ c@(Call ar (Fast True) f@(Fun _ body) xs) = do + tc <- mayTailcall body + return $ if tc then c else Call ar (Fast False) f xs + unTr _ x = + return x + + -- If we know for certain that the function we're tailcalling will not + -- tailcall in turn we should not tailcall it, since that would mean two + -- activation records on the stack - one for the trampoline and one for + -- the function itself. + unTC ntcs (Tailcall c@(Call _ (Fast _) (Var v) _)) + | v `S.member` ntcs = + return $ Return c + unTC _ tc@(Tailcall c@(Call _ (Fast _) (Fun _ body) _)) = do + maytc <- mayTailcall body + if not maytc then return (Return c) else return tc + unTC _ x = + return x + +-- | 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 + mapJS (const True) inl pure ast + where + inl (Fun as body) = Fun as <$> go Nothing body + inl (Thunk upd body) = Thunk upd <$> go Nothing body + inl ex = pure ex + + goAlt outside (ex, stm) = (ex,) <$> go outside stm + + go outside (Case c d as next) = do + next' <- go outside next + case returnLike next' of + outside'@(Just (Var _, _)) -> + Case c <$> go outside' d <*> mapM (goAlt outside') as <*> pure Stop + _ -> + Case c <$> go Nothing d <*> mapM (goAlt Nothing) as <*> pure next' + go _ (Forever s) = do + Forever <$> go Nothing s + go outside (Assign l@(NewVar _ lhs) r next) = do + next' <- go outside next + case (next', outside) of + (Stop, Just (Var v, ret)) | v == lhs -> return $ ret r + (Return (Var v), _) | v == lhs -> return $ Return r + (ThunkRet (Var v), _) | v == lhs -> return $ ThunkRet r + (Assign ll (Var v) Stop, _) | v == lhs -> return $ Assign ll r Stop + _ -> return $ Assign l r next' + go outside (Assign l r next) = do + Assign l r <$> go outside next + go _ stm = do + return stm + +-- | Extract the expression returned from a Return of ThunkRet, as well as +-- a function to recreate that type of return. +returnLike :: Stm -> Maybe (Exp, Exp -> Stm) +returnLike (Return e) = Just (e, Return) +returnLike (ThunkRet e) = Just (e, ThunkRet) +returnLike _ = Nothing + +-- | Shrink case statements as much as possible. +shrinkCase :: JSTrav ast => ast -> TravM ast +shrinkCase = + mapJS (const True) pure shrink + where + shrink (Case _ def [] next) + | def == Stop = return next + | otherwise = replaceFinalStm next (== Stop) def + shrink stm = return stm + +-- | Turn any calls in tail position into tailcalls. +-- Must run after @tailLoopify@ or we won't get loops for simple tail +-- recursive functions. +trampoline :: Exp -> TravM Exp +trampoline = mapJS (pure True) pure bounce + where + bounce (Return (Call arity call f args)) = do + return $ Tailcall $ Call arity call' f args + where + call' = + case call of + Normal _ -> Normal False + Fast _ -> Fast False + c -> c + bounce s = do + return s + +-- | 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 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 continueSentinel + b <- mapJS (not <$> isLambda) pure (replaceByAssign ret args') body + tailcalls <- occurrences (const True) isHiddenTailcall body + let nn = newName f + nv = NewVar False nn + body' = + Forever $ + Assign nv (Call 0 (Fast (tailcalls > Never)) (Fun args b) + (map Var args')) $ + Case (Var nn) (Return (Var nn)) [(continueSentinel, Stop)] $ + Stop + return $ Fun args' body' + False -> do + let c = Cont + body' <- mapJS (not <$> isLambda) pure (replaceByAssign c args) body + return $ Fun args (Forever body') + else do + return fun + where + continueSentinel = Var $ Foreign "__continue" + isTailRec (Stm (Return (Call _ _ (Var f') _)) _) = f == f' + isTailRec _ = False + + isHiddenTailcall (Stm (Return (Call {})) _) = True + isHiddenTailcall _ = False + + -- Only traverse until we find a closure + createsClosures = foldJS (\acc _ -> not acc) isClosure False + isClosure _ (Exp (Fun _ _) _) = pure True + isClosure _ (Exp (Thunk _ _) _) = pure True + isClosure acc _ = pure acc + + -- Assign any changed vars, then loop. + replaceByAssign end as (Return (Call _ _ (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 False (Var v)) (Var $ newName v) final) + | otherwise = + (next, Assign (LhsExp False (Var v)) x final) + + newName (Internal (Name n mmod) _ _) = + Internal (Name (BS.cons ' ' n) mmod) "" True + newName n = + n + + contains (Var v) var = v == var + contains (Lit _) _ = False + contains (JSLit _) _ = 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 (Member o _) var = o `contains` var + contains (Arr xs) var = any (`contains` var) xs + contains (Obj xs) var = any (`contains` var) (map snd xs) + contains (AssignEx l r) var = l `contains` var || r `contains` var + contains (IfEx c t e) var = any (`contains` var) [c,t,e] + contains (Eval x) var = x `contains` var + contains (Thunk _ _) _ = False +tailLoopify _ fun = do + return fun + +-- | Inline a tailcalled function @f@ when: +-- +-- * @f@ does not refer to itself; and +-- * @f@ is defined immediately before its call site. +-- (@let f = ... in tailcall f@) +-- +-- Should be called *after* 'tailLoopify' but *before* trampoline for best +-- effect. +inlineShortJumpTailcall :: JSTrav ast => ast -> TravM ast +inlineShortJumpTailcall ast = do + mapJS (const True) return inl ast + where + inl stm@(Assign (NewVar True f) (Fun as b) tc) + | Just (f', as') <- getTailcallInfo tc, f == f' = do + occs <- occurrences (const True) (isEqualTo f) b + case (occs, zipAssign (map (NewVar True) as) as' b) of + (Never, Just b') -> return b' + _ -> return stm + inl stm = + return stm + isEqualTo v' (Exp (Var v) _) = v == v' + isEqualTo _ _ = False + +-- | Extract the function being called and its argument list from a +-- @Tailcall (Call ...)@ or @Return (Call ...)@, provided that the call is +-- completely saturated. +getTailcallInfo :: Stm -> Maybe (Var, [Exp]) +getTailcallInfo (Tailcall (Call 0 _ (Var f) as)) = Just (f, as) +getTailcallInfo (Return (Call 0 _ (Var f) as)) = Just (f, as) +getTailcallInfo _ = Nothing + +-- | Assign several variables, before executing a statement. +zipAssign :: [LHS] -> [Exp] -> Stm -> Maybe Stm +zipAssign l r final + | length l == length r = Just $ go l r + | otherwise = Nothing + where + go (v:vs) (x:xs) = Assign v x (go vs xs) + go [] [] = final + go _ _ = error "zipAssign: different number of lhs and rhs!" + +-- | Eliminate evaluation of vars that are guaranteed not to be thunks. +-- Mainly useful in 'topLevelInline'. +unevalLits :: JSTrav ast => ast -> TravM ast +unevalLits ast = do + lits <- foldJS (\_ _ -> True) gatherLits S.empty ast + mapJS (const True) pure (pure . removeUpdate (`S.member` lits)) ast + where + gatherLits s (Stm (Assign (NewVar _ v) rhs _) _) + | definitelyNotThunk rhs = pure $ S.insert v s + | Var v' <- rhs, v' `S.member` s = pure $ S.insert v s + gatherLits s _ = pure s + +-- | Inline calls to JS @eval@, @__set@, @__get@ and @__has@ and apply +-- functions for "Haste.Foreign". +inlineJSPrimitives :: JSTrav ast => ast -> TravM ast +inlineJSPrimitives = + inlineFuns >=> optimizeThunks + where + inlineFuns = mapJS (const True) (return . inl) return + inl ex@(Call _ (Fast _) (Var (Foreign fn)) args) = + case (fn, args) of + ("eval", [Lit (LStr s)]) -> JSLit s + ("__app0", [f]) -> Call 0 (Fast False) f [] + ("__app1", f:xs) -> Call 0 (Fast False) f xs + ("__app2", f:xs) -> Call 0 (Fast False) f xs + ("__app3", f:xs) -> Call 0 (Fast False) f xs + ("__app4", f:xs) -> Call 0 (Fast False) f xs + ("__app5", f:xs) -> Call 0 (Fast False) f xs + ("__get", [o, k]) -> Index o k + ("__set", [o, k, v]) -> AssignEx (Index o k) v + ("__has", [o, k]) -> BinOp StrictNeq (Index o k) + (JSLit "undefined") + _ -> ex + inl ex = + ex + +-- | Turn all assignments of the form @var v1 = e ; exp@ into @exp[v1/e]@, +-- provided that @v1@ is not used as a known location and @e@ is either a +-- variable or a non-string literal. +-- Also does not inline vars into lambdas. +-- Should go before 'tailLoopify'. +assignToSubst :: JSTrav ast => ast -> TravM ast +assignToSubst ast = do + mapJS (const True) return inl ast + where + inl stm@(Assign (NewVar _ v) x next) | not (isKnownLoc v) = do + case x of + (Var _) -> do + -- TODO: this can be replaced by a map (to replace) and a count of + -- remaining occurrences of v (fold) + (c, stm') <- replaceExWithCount (isSafeForInlining) (Var v) x next + (c', _) <- replaceExWithCount (pure True) (Var v) x next + if c == c' + then return stm' -- No occurrences inside lambda + else return stm + (Lit (LStr _)) -> return stm + (Lit _) -> replaceEx (pure True) (Var v) x next + _ -> return stm + inl stm = do + return stm + +-- | Perform various trivially correct local inlinings: +-- var x = e; return [0, e] (boxing at the end of a thunk/function) +-- => [0, e] +-- thunk(x) where x is non-computing and non-recursive +-- => x +smallStepInline :: JSTrav ast => ast -> TravM ast +smallStepInline ast = do + mapJS (const True) return inl ast + where + inl (Assign (NewVar _ v) ex (Return (Arr [l@(Lit _), Var v']))) + | v == v' = + return (Return (Arr [l, ex])) + inl (Assign (NewVar _ v) ex (ThunkRet (Arr [l@(Lit _), Var v']))) + | v == v' = + return (ThunkRet (Arr [l, ex])) + -- Unpack thunks which don't provide actual laziness. + inl (Assign lhs@(NewVar _ v) t@(Thunk _ _) next) + | Just ex <- fromThunkEx t, safeToUnThunk ex = do + case ex of + Thunk _ _ -> return $ Assign lhs ex next + _ -> Assign lhs ex <$> eliminateEvalOf v next + -- Merge @a = eval(a) ; a = eval(a)@ into a single eval. + inl stm@(Assign (LhsExp _ (Var v1)) (Eval (Var v1')) next) + | v1 == v1' = do + case next of + stm'@(Assign (LhsExp _ (Var v2)) (Eval (Var v2')) _) + | v1 == v2 && v1' == v2' -> do + return stm' + _ -> do + return stm + inl stm = + return stm + +-- | Eliminate elimination of a variable. Only use when *absolutely certain* +-- that the variable can never be a thunk. +eliminateEvalOf :: JSTrav ast => Var -> ast -> TravM ast +eliminateEvalOf v ast = mapJS (const True) return elim ast + where + elim (Assign (LhsExp _ (Var v')) (Eval (Var v'')) next) + | v' == v'' && v == v' = + return next + elim stm = + return stm + +-- | Is the given expression safe to extract from a thunk? +-- An expression is safe to unthunk iff evaluating it will not cause +-- computation to take place or a variable to be dereferenced. +safeToUnThunk :: Exp -> Bool +safeToUnThunk ex = + case ex of + Lit _ -> True + JSLit l -> isJSFunDecl l + Fun _ _ -> True + Thunk _ _ -> True + Arr arr -> all safeToUnThunk arr + _ -> False + +-- | Create a mapping from (function name, argument #) to argument names +-- for all function arguments. +gatherArgNames :: JSTrav ast => ast -> TravM ArgMap +gatherArgNames = foldJS (\_ _ -> True) (\m x -> pure (upd m x)) M.empty + where + upd m (Stm (Assign (NewVar _ v) (Fun args _) _) _) = M.insert v args m + upd m _ = m + +flowOpts :: Stm -> TravM Stm +flowOpts ast = do + argvars <- gatherArgNames ast + let info = findVarInfos argvars ast + ast' <- mapJS (const True) (pure . removeEvals info) pure ast + mapJS (const True) (pure . makeFastCall info) pure ast' + where + name (Foreign s) = show s + name (Internal s _ _) = show $ nameIdent s + + alwaysStrict infos v = + case M.lookup v infos of + Just info -> varStrict info == Strict + _ -> False + + arityIsAlways infos v = do + info <- M.lookup v infos + varArity info + + removeEvals info (Eval ex@(Var v)) | alwaysStrict info v = ex + removeEvals _ ex = ex + + makeFastCall info ex@(Call _ (Normal bounce) f@(Var v) xs) = + case arityIsAlways info v of + Just ar' + | length xs == ar' -> Call 0 (Fast bounce) f xs + | length xs > ar' -> Call 0 (Normal bounce) + (Call 0 (Fast bounce) f (take ar' xs)) + (drop ar' xs) + _ -> ex + makeFastCall _ ex = ex diff --git a/src/Haste/AST/PP.hs b/src/Haste/AST/PP.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST/PP.hs @@ -0,0 +1,190 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, + GeneralizedNewtypeDeriving, CPP #-} +-- | Haste AST pretty printing machinery. The actual printing happens in +-- Haste.AST.Print. +module Haste.AST.PP where +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 qualified Data.ByteString.Char8 as BSS +import Data.ByteString (ByteString) +import Haste.AST.Syntax (Name (..)) +import Data.ByteString.Builder +import Haste.Config +import Haste.AST.PP.Opts + +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 :: Config + -> IndentLvl + -> NameSupply + -> Builder + -> (NameSupply, Builder, a)} + +instance Monad PP where + PP m >>= f = PP $ \cfg indentlvl ns b -> + case m cfg indentlvl ns b of + (ns', b', x) -> unPP (f x) cfg indentlvl ns' 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 .+. + +-- | Generate the final name for a variable. +-- Up until this point, internal names may be just about anything. +-- The "final name" scheme ensures that all internal names end up with a +-- proper, unique JS name. +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) + +-- | Returns the value of the given pretty-printer option. +getOpt :: (PPOpts -> a) -> PP a +getOpt f = getCfg (f . ppOpts) + +-- | Runs the given printer iff the specified PP option is True. +whenOpt :: (PPOpts -> Bool) -> PP () -> PP () +whenOpt f p = getOpt f >>= \x -> when x p + +-- | Returns the value of the given pretty-printer option. +getCfg :: (Config -> a) -> PP a +getCfg f = PP $ \cfg _ ns b -> (ns, b, f cfg) + +-- | Pretty print an AST. +pretty :: Pretty a => Config -> a -> BS.ByteString +pretty cfg ast = + case runPP cfg (pp ast) of + (b, _) -> toLazyByteString b + +-- | Run a pretty printer. +runPP :: Config -> PP a -> (Builder, a) +runPP cfg p = + case unPP p cfg 0 emptyNS mempty of + (_, b, x) -> (b, x) + +-- | Pretty-print a program and return the final name for its entry point. +prettyProg :: Pretty a => Config -> Name -> a -> (Builder, Builder) +prettyProg cfg mainSym ast = runPP cfg $ do + pp ast + hsnames <- getOpt preserveNames + if hsnames + then return $ buildStgName mainSym + else buildFinalName <$> finalNameFor mainSym + +-- | JS-mangled version of an internal name. +buildStgName :: Name -> Builder +buildStgName (Name n mq) = + byteString "$hs$" <> qual <> byteString (BSS.map mkjs n) + where + qual = case mq of + Just (_, m) -> byteString (BSS.map mkjs m) <> byteString "$" + _ -> mempty + mkjs c + | c >= 'a' && c <= 'z' = c + | c >= 'A' && c <= 'Z' = c + | c >= '0' && c <= '9' = c + | c == '$' = c + | otherwise = '_' + +-- | Turn a FinalName into a Builder. +buildFinalName :: FinalName -> Builder +buildFinalName (FinalName 0) = + fromString "_0" +buildFinalName (FinalName fn) = + charUtf8 '_' <> 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 (charUtf8 (chars ! ix) <> acc) + +-- | Indent the given builder another step. +indent :: PP a -> PP a +indent (PP p) = PP $ \cfg indentlvl ns b -> + if useIndentation (ppOpts cfg) + then p cfg (indentlvl+1) ns b + else p cfg 0 ns b + +class Buildable a where + put :: a -> PP () + +instance Buildable Builder where + put x = PP $ \_ _ ns b -> (ns, b <> x, ()) +instance Buildable ByteString where + put = put . byteString +instance Buildable String where + put = put . stringUtf8 +instance Buildable Char where + put = put . charUtf8 +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 True = "true" + put False = "false" + +-- | Emit indentation up to the current level. +ind :: PP () +ind = PP $ \cfg indentlvl ns b -> + (ns, foldl' (<>) b (replicate indentlvl (indentStr $ ppOpts cfg)), ()) + +-- | 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 (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/Haste/AST/PP/Opts.hs b/src/Haste/AST/PP/Opts.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST/PP/Opts.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Basic config types for Haste's pretty printer. +module Haste.AST.PP.Opts where +import Data.ByteString.Builder + +-- | Pretty-printing options +data PPOpts = PPOpts { + nameComments :: Bool, -- ^ Emit comments for externals? + externalAnnotation :: Bool, -- ^ Emit comments for names? + useIndentation :: Bool, -- ^ Should we indent at all? + indentStr :: Builder, -- ^ Indentation step. + useNewlines :: Bool, -- ^ Use line breaks? + useSpaces :: Bool, -- ^ Use spaces other than where necessary? + preserveNames :: Bool -- ^ Use STG names? + } + +defaultPPOpts :: PPOpts +defaultPPOpts = PPOpts { + nameComments = False, + externalAnnotation = False, + useIndentation = False, + indentStr = " ", + useNewlines = False, + useSpaces = False, + preserveNames = False + } + +-- | Print code using indentation, whitespace and newlines. +withPretty :: PPOpts -> PPOpts +withPretty opts = opts { + useIndentation = True, + indentStr = " ", + useNewlines = True, + useSpaces = True + } + +-- | Annotate non-local, non-JS symbols with qualified names. +withAnnotations :: PPOpts -> PPOpts +withAnnotations opts = opts {nameComments = True} + +-- | Annotate externals with /* EXTERNAL */ comment. +withExtAnnotation :: PPOpts -> PPOpts +withExtAnnotation opts = opts {externalAnnotation = True} + +-- | Preserve STG names. Currently slightly broken; don't use. +withHSNames :: PPOpts -> PPOpts +withHSNames opts = opts {preserveNames = True} diff --git a/src/Haste/AST/Print.hs b/src/Haste/AST/Print.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST/Print.hs @@ -0,0 +1,307 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, GADTs, OverloadedStrings, CPP #-} +module Haste.AST.Print () where +import Prelude hiding (LT, GT) +import Haste.Config +import Haste.AST.Syntax +import Haste.AST.Op +import Haste.AST.PP as PP +import Haste.AST.PP.Opts as PP +import Data.ByteString.Builder +import Control.Monad +import Data.Char +import Numeric (showHex) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.UTF8 as BS + +instance Pretty Var where + pp (Foreign name) = do + put name + doComment <- getOpt externalAnnotation + when doComment . put $ byteString "/* EXTERNAL */" + pp (Internal name@(Name u _) comment _) = do + hsnames <- getOpt preserveNames + if hsnames + then put $ buildStgName name + else do + pp name + doComment <- getOpt nameComments + when doComment $ do + put $ byteString "/* " + if BS.null comment + then put u + else put comment + put $ byteString " */" + + +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 $ BS.toString s) .+. "\"" + where + fixQuotes ('\\':xs) = "\\\\" ++ fixQuotes xs + fixQuotes ('"':xs) = '\\':'"' : fixQuotes xs + fixQuotes ('\'':xs) = '\\':'\'' : fixQuotes xs + fixQuotes ('\r':xs) = '\\':'r' : fixQuotes xs + fixQuotes ('\n':xs) = '\\':'n' : fixQuotes xs + fixQuotes (x:xs) + | ord x <= 127 = x : fixQuotes xs + | otherwise = toHex x ++ fixQuotes xs + fixQuotes _ = [] + pp (LBool b) = put b + pp (LInt n) = put n + pp (LNull) = "null" + +-- | Generate a Haskell \uXXXX escape sequence for a char if it's >127. +toHex :: Char -> String +toHex c = + case ord c of + n | n < 127 -> [c] + | otherwise -> "\\u" ++ exactlyFour (showHex (n `rem` 65536) "") + +-- | Truncate and pad a string to exactly four characters. '0' is used for padding. +exactlyFour :: String -> String +exactlyFour s = + pad (4-len) $ drop (len-4) s + where + len = length s + pad 0 cs = cs + pad n cs = '0' : pad (n-1) cs + + +-- | 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 (JSLit l) = + put l + pp (Not ex) = do + case neg ex of + Just ex' -> pp ex' + _ -> if expPrec (Not ex) > expPrec ex + then "!(" .+. pp ex .+. ")" + else "!" .+. pp ex + pp bop@(BinOp _ _ _) = + case norm bop of + BinOp op a b -> opParens op a b + ex -> pp ex + pp (Fun args body) = do + "function(" .+. ppList sep args .+. "){" .+. newl + indent $ pp body + ind .+. "}" + pp (Call _ call f args) = do + case call of + Normal True -> "B(" .+. normalCall .+. ")" + Normal False -> normalCall + Fast True -> "B(" .+. fastCall .+. ")" + Fast False -> fastCall + Method m -> + pp f .+. put (BS.cons '.' m) .+. "(" .+. ppList sep args .+. ")" + where + normalCall = + case args of + [x] -> "A1(" .+. pp f .+. "," .+. pp x .+. ")" + [_,_] -> "A2(" .+. pp f .+. "," .+. ppList sep args .+. ")" + [_,_,_] -> "A3(" .+. pp f .+. "," .+. ppList sep args .+. ")" + _ -> "A(" .+. pp f .+. ",[" .+. ppList sep args .+. "])" + fastCall = ppCallFun f .+. "(" .+. ppList sep args .+. ")" + ppCallFun fun@(Fun _ _) = "(" .+. pp fun .+. ")" + ppCallFun fun = pp fun + pp e@(Index arr ix) = do + if expPrec e > expPrec arr + then "(" .+. pp arr .+. ")" + else pp arr + "[" .+. pp ix .+. "]" + pp (Member obj m) = do + pp obj .+. "." .+. put m + pp (Obj ms) | and $ zipWith (==) ["_","a","b","c","d","e"] (map fst ms) = + ppADT ms + pp (Obj members) = do + "{" .+. ppList "," members .+. "}" + pp (Arr exs) = do + "[" .+. ppList sep exs .+. "]" + pp (AssignEx l r) = do + pp l .+. sp .+. "=" .+. sp .+. pp r + pp e@(IfEx c th el) = do + if expPrec e > expPrec c + then "(" .+. pp c .+. ")" + else pp c + sp .+. "?" .+. sp .+. pp th .+. sp .+. ":" .+. sp .+. pp el + pp (Eval x) = do + "E(" .+. pp x .+. ")" + pp (Thunk True x) = do + "new T(function(){" .+. newl .+. indent (pp x) .+. ind .+. "})" + pp (Thunk False x) = do + "new T(function(){" .+. newl .+. indent (pp x) .+. ind .+. "},1)" + +-- | Pretty-print an object representing an ADT. +ppADT :: [(BS.ByteString, Exp)] -> PP () +ppADT ms = do + useClassy <- getCfg useClassyObjects + if useClassy && args <= 6 + then "new T" .+. put args .+. "(" .+. ppList "," (map snd ms) .+. ")" + else "{" .+. ppList "," ms .+. "}" + where + args = length ms-1 + +instance Pretty (BS.ByteString, Exp) where + pp (n, x) = put n .+. ":" .+. pp x + +instance Pretty (Var, Exp) where + pp (v, ex) = pp v .+. sp .+. "=" .+. sp .+. pp ex + +instance Pretty Bool where + pp True = "true" + pp False = "false" + +-- | Print a series of NewVars at once, to avoid unnecessary "var" keywords. +ppAssigns :: Stm -> PP () +ppAssigns stm = do + line $ "var " .+. ppList ("," .+. newl .+. ind) 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 _ _ _ next -> finalStm next + Forever s' -> finalStm s' + _ -> return s + +instance Pretty Stm where + pp (Case cond def alts next) = do + prettyCase cond def alts + pp next + 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 (Stop) = do + return () + pp (Tailcall call) = do + b <- getCfg tailChainBound + if b <= 1 + then line $ "return new F(function(){return " .+. pp call .+. ";});" + else line $ "return C > " .+. put (b-1) .+. " ? new F(function(){return " + .+. pp call .+. ";}) : (++C," .+. pp call .+. ");" + pp (ThunkRet ex) = do + line $ "return " .+. pp ex .+. ";" + +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 + (_, Stop) -> do + line $ "if(" .+. pp (neg' (test con)) .+. "){" + indent $ pp def + line "}" + (Stop, _) -> 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 + test (Lit (LBool True)) = cond + test (Lit (LBool False)) = Not cond + test (Lit (LNum 0)) = Not cond + test c = BinOp Eq cond c + neg' c = maybe (Not c) id (neg c) +prettyCase _ def [] = do + pp def +prettyCase cond def alts = do + 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 .+. ")" + _ -> parensR + parensL a .+. put (stringUtf8 $ show op) .+. bparens b + where + parensL x = if expPrec x < opPrec op + then "(" .+. pp x .+. ")" + else pp x + parensR x = if expPrec x <= opPrec op + then "(" .+. pp x .+. ")" + else pp x + +-- | Normalize an operator expression by shifting parentheses to the left for +-- all associative operators and eliminating comparisons with true/false. +norm :: Exp -> Exp +norm (BinOp op a (BinOp op' b c)) | op == op' && opIsAssoc op = + norm (BinOp op (BinOp op a b) c) +norm (BinOp Eq a (Lit (LBool True))) = norm a +norm (BinOp Eq (Lit (LBool True)) b) = norm b +norm (BinOp Eq a (Lit (LBool False))) = Not (norm a) +norm (BinOp Eq (Lit (LBool False)) b) = Not (norm b) +norm (BinOp Neq a (Lit (LBool True))) = Not (norm a) +norm (BinOp Neq (Lit (LBool True)) b) = Not (norm b) +norm (BinOp Neq a (Lit (LBool False))) = norm a +norm (BinOp Neq (Lit (LBool False)) b) = norm b +norm e = e diff --git a/src/Haste/AST/Syntax.hs b/src/Haste/AST/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST/Syntax.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances, CPP, + OverloadedStrings #-} +-- | Abstract syntax of Haste's intermediate format. +module Haste.AST.Syntax where +import qualified Data.Set as S +#if __GLASGOW_HASKELL__ >= 708 +import qualified Data.Map.Strict as M +#else +import qualified Data.Map as M +#endif +import Haste.AST.Op +import qualified Data.ByteString.Char8 as BS + +type Arity = Int +type Comment = BS.ByteString +type Reorderable = Bool + +-- | A Name consists of a variable name and optional (package, module) +-- information. +data Name = Name { + nameIdent :: !BS.ByteString, + nameQualifier :: !(Maybe (BS.ByteString, BS.ByteString)) + } deriving (Eq, Ord, Show) + +class HasModule a where + moduleOf :: a -> Maybe BS.ByteString + pkgOf :: a -> Maybe BS.ByteString + +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 + +type KnownLoc = Bool + +-- | Representation of variables. +data Var where + Foreign :: !BS.ByteString -> Var + -- | Being a "known location" means that we can never substitute this + -- variable for another one, as it is used to hold "return values" from + -- case statements, tail loopification and similar. + -- If a variable is *not* a known location, then we may always perform the + -- substitution @a=b ; exp => exp [a/b]@. + Internal :: !Name -> !Comment -> !KnownLoc -> Var + deriving (Show) + +isKnownLoc :: Var -> Bool +isKnownLoc (Internal _ _ knownloc) = knownloc +isKnownLoc _ = False + +instance Eq Var where + {-# INLINE (==) #-} + (Foreign f1) == (Foreign f2) = f1 == f2 + (Internal i1 _ _) == (Internal i2 _ _) = i1 == i2 + _ == _ = False + +instance Ord Var where + {-# INLINE compare #-} + 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. +data LHS where + -- | Introduce a new variable. May be reorderable. + -- Invariant: a NewVar must be the first occurrence of a 'Var' in its + -- scope. + NewVar :: !Reorderable -> !Var -> LHS + -- | Assign a value to an arbitrary LHS expression. May be reorderable. + LhsExp :: !Reorderable -> !Exp -> LHS + deriving (Eq, Show) + +-- | Distinguish between normal, optimized and method calls. +-- Normal and optimized calls take a boolean indicating whether the called +-- function should trampoline or not. This defaults to True, and should +-- only be set to False when there is absolutely no possibility whatsoever +-- that the called function will tailcall. +data Call where + Normal :: !Bool -> Call + Fast :: !Bool -> Call + Method :: !BS.ByteString -> Call + deriving (Eq, Show) + +-- | Literals; nothing fancy to see here. +data Lit where + LNum :: !Double -> Lit + LStr :: !BS.ByteString -> Lit + LBool :: !Bool -> Lit + LInt :: !Integer -> Lit + LNull :: Lit + deriving (Eq, Show) + +-- | Expressions. Completely predictable. +data Exp where + Var :: !Var -> Exp + Lit :: !Lit -> Exp + -- | A literal JS snippet. + -- Invariant: JSLits must not perform side effects or significant + -- computation. + JSLit :: !BS.ByteString -> Exp + Not :: !Exp -> Exp + BinOp :: !BinOp -> Exp -> !Exp -> Exp + Fun :: ![Var] -> !Stm -> Exp + Call :: !Arity -> !Call -> !Exp -> ![Exp] -> Exp + Index :: !Exp -> !Exp -> Exp + Member :: !Exp -> !BS.ByteString -> Exp + Arr :: ![Exp] -> Exp + Obj :: ![(BS.ByteString, Exp)] -> Exp + AssignEx :: !Exp -> !Exp -> Exp + IfEx :: !Exp -> !Exp -> !Exp -> Exp + Eval :: !Exp -> Exp + Thunk :: !Bool -> !Stm -> Exp -- Thunk may be updatable or not + deriving (Eq, Show) + +-- | Is the given expression guaranteed to not be a thunk? +-- @definitelyNotThunk e <=> safe to skip evaluation of e@ +definitelyNotThunk :: Exp -> Bool +definitelyNotThunk (Lit {}) = True +definitelyNotThunk (JSLit {}) = True +definitelyNotThunk (Not {}) = True +definitelyNotThunk (BinOp {}) = True +definitelyNotThunk (Fun {}) = True +definitelyNotThunk (Arr {}) = True +definitelyNotThunk (Eval {}) = True +definitelyNotThunk _ = False + +-- | 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] -> !Stm -> Stm + Forever :: !Stm -> Stm + Assign :: !LHS -> !Exp -> !Stm -> Stm + Return :: !Exp -> Stm + Cont :: Stm + Stop :: Stm -- Do nothing at all past this point + Tailcall :: !Exp -> Stm + ThunkRet :: !Exp -> Stm -- Return from a Thunk + deriving (Eq, Show) + +-- | Case alternatives - an expression to match and a branch. +type Alt = (Exp, Stm) + +-- | Represents a module. A module has a name, an owning +-- package, a dependency map of all its definitions, and a bunch of +-- definitions. +data Module = Module { + modPackageId :: !BS.ByteString, + modName :: !BS.ByteString, + modDeps :: M.Map Name (S.Set Name), + modDefs :: M.Map Name Exp + } + +-- | Merge two modules. The module and package IDs of the second argument are +-- used, and the second argument will take precedence for symbols which exist +-- in both. +merge :: Module -> Module -> Module +merge m1 m2 = Module { + modPackageId = modPackageId m2, + modName = modName m2, + modDeps = M.union (modDeps m1) (modDeps m2), + modDefs = M.union (modDefs m1) (modDefs m2) + } + +-- | Imaginary module for foreign code that may need one. +foreignModule :: Module +foreignModule = Module { + 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 False $ Var blackHoleVar + +-- | Name of the data constructor tag field. +dataConTagField :: BS.ByteString +dataConTagField = "_" + +-- | Infinite list of data constructor names. +dataConFieldNames :: [BS.ByteString] +dataConFieldNames = names + where + prefix = BS.singleton '_' + names = concat [small, capital, map (BS.append prefix) names] + small = map BS.singleton ['a'..'z'] + capital = map BS.singleton ['A'..'Z'] + +-- | The global "zero object", which represents @{_:0}@. +zeroObject :: Exp +zeroObject = Var $ Foreign "__Z" + +-- | The variable of the blackHole LHS. +blackHoleVar :: Var +blackHoleVar = Internal (Name "" (Just ("$blackhole", "$blackhole"))) "" False + +-- | 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 (AssignEx _ _) = 0 +expPrec (Not _) = 500 +expPrec _ = 1000 diff --git a/src/Haste/AST/Traversal.hs b/src/Haste/AST/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Haste/AST/Traversal.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE FlexibleInstances, TupleSections, PatternGuards, BangPatterns #-} +-- | Generic traversal of JSTarget AST types. +module Haste.AST.Traversal where +import Control.Applicative +import Control.Monad +import Control.Monad.Identity +import Haste.AST.Syntax + +-- | AST nodes we'd like to fold and map over. +data ASTNode = Exp !Exp !Bool | Stm !Stm !Bool | Shared !Stm + +type TravM a = Identity a + +runTravM :: TravM a -> a +runTravM = runIdentity + +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 + {-# INLINE const' #-} + 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 = go + where + go acc ast + | tr acc $! Exp ast False = do + (acc', x) <- do + case ast of + v@(Var _) -> pure (acc, v) + l@(Lit _) -> pure (acc, l) + l@(JSLit _) -> pure (acc, l) + Not ex -> fmap Not <$> go acc ex + BinOp op a b -> do + (acc', a') <- go acc a + (acc'', b') <- go acc' b + return (acc'', BinOp op a' b') + Fun vs stm -> fmap (Fun vs) <$> foldMapJS tr fe fs acc stm + Call ar c f xs -> do + (acc', f') <- go acc f + (acc'', xs') <- foldMapJS tr fe fs acc' xs + return (acc'', Call ar c f' xs') + Index arr ix -> do + (acc', arr') <- go acc arr + (acc'', ix') <- go acc' ix + return (acc'', Index arr' ix') + Member ex m -> do + (acc', ex') <- go acc ex + return (acc', Member ex' m) + Arr exs -> fmap Arr <$> foldMapJS tr fe fs acc exs + Obj ms -> do + let (ts, exs) = unzip ms + (acc', exs') <- foldMapJS tr fe fs acc exs + return (acc', Obj $ zip ts exs') + AssignEx l r -> do + (acc', l') <- go acc l + (acc'', r') <- go acc' r + return (acc'', AssignEx l' r') + IfEx c th el -> do + (acc', c') <- go acc c + (acc'', th') <- if tr acc (Exp th True) + then go acc' th + else return (acc', th) + (acc''', el') <- if tr acc (Exp el True) + then go acc'' el + else return (acc'', el) + return (acc''', IfEx c' th' el') + Eval x -> fmap Eval <$> go acc x + Thunk upd x -> fmap (Thunk upd) <$> foldMapJS tr fe fs acc x + fe acc' x + | otherwise = do + fe acc ast + + foldJS tr f = go + where + go acc ast + | tr acc $! expast = do + flip f expast =<< do + case ast of + Var _ -> return acc + Lit _ -> return acc + JSLit _ -> return acc + Not ex -> go acc ex + BinOp _ a b -> go acc a >>= flip go b + Fun _ stm -> foldJS tr f acc stm + Call _ _ fun xs -> go acc fun >>= flip (foldJS tr f) xs + Index arr ix -> go acc arr >>= flip go ix + Member obj _ -> go acc obj + Arr exs -> foldJS tr f acc exs + Obj ms -> foldJS tr f acc (map snd ms) + AssignEx l r -> go acc l >>= flip go r + IfEx c th el -> do + acc' <- go acc c + acc'' <- if tr acc $! Exp th True + then go acc' th + else return acc' + if tr acc $! Exp th True + then go acc'' el + else return acc'' + Eval ex -> go acc ex + Thunk _upd stm -> foldJS tr f acc stm + | otherwise = + f acc expast + where !expast = Exp ast False + +instance JSTrav Stm where + foldMapJS tr fe fs = go + where + go acc ast + | tr acc $! Stm ast False = do + (acc', x) <- do + case ast of + Case ex def as nxt -> do + (acc1, ex') <- foldMapJS tr fe fs acc ex + (acc2, def') <- go acc1 def + (acc3, as') <- foldMapJS tr fe fs acc2 as + (acc4, nxt') <- if tr acc $! Shared nxt + then go acc3 nxt + else return (acc3, nxt) + return (acc4, Case ex' def' as' nxt') + Assign lhs ex next -> do + (acc', lhs') <- foldMapJS tr fe fs acc lhs + (acc'', ex') <- foldMapJS tr fe fs acc' ex + (acc''', next') <- go acc'' next + return (acc''', Assign lhs' ex' next') + Forever stm -> fmap Forever <$> go acc stm + Return ex -> fmap Return <$> foldMapJS tr fe fs acc ex + Cont -> return (acc, ast) + Stop -> return (acc, ast) + Tailcall ex -> fmap Tailcall <$> foldMapJS tr fe fs acc ex + ThunkRet ex -> fmap ThunkRet <$> foldMapJS tr fe fs acc ex + fs acc' x + | otherwise = do + fs acc ast + + foldJS tr f = go + where + go acc ast + | tr acc stmast = do + flip f stmast =<< do + case ast of + Case ex def as nxt -> do + acc' <- foldJS tr f acc ex >>= flip go def + acc'' <- foldJS tr f acc' as + if tr acc $! Shared nxt + then go acc'' nxt + else return acc'' + Assign lhs ex next -> do + foldJS tr f acc lhs >>= flip (foldJS tr f) ex >>= flip go next + Forever stm -> foldJS tr f acc stm + Return ex -> foldJS tr f acc ex + Cont -> return acc + Stop -> return acc + Tailcall ex -> foldJS tr f acc ex + ThunkRet ex -> foldJS tr f acc ex + | otherwise = + f acc stmast + where !stmast = Stm ast False + +instance JSTrav (Exp, Stm) where + foldMapJS tr fe fs acc (ex, stm) = do + (acc', stm') <- if tr acc (Stm stm True) + then foldMapJS tr fe fs acc stm + else return (acc, stm) + (acc'', ex') <- if tr acc (Exp ex True) + then foldMapJS tr fe fs acc' ex + else return (acc', ex) + return (acc'', (ex', stm')) + foldJS tr f acc (ex, stm) = do + acc' <- if tr acc (Stm stm True) + then foldJS tr f acc stm + else return acc + if tr acc (Exp ex True) + then foldJS tr f acc' ex + else return acc' + +instance JSTrav LHS where + foldMapJS _ _ _ acc lhs@(NewVar _ _) = + return (acc, lhs) + foldMapJS t fe fs a (LhsExp r ex) = + fmap (LhsExp r) <$> foldMapJS t fe fs a ex + foldJS _ _ acc (NewVar _ _) = return acc + foldJS tr f acc (LhsExp _ ex) = foldJS tr f acc ex + +-- | Returns the final statement of a line of statements. +finalStm :: Stm -> TravM Stm +finalStm = go + where + go (Case _ _ _ next) = go next + go (Forever s) = go s + go (Assign _ _ next) = go next + go s = return s + +-- | Replace the final statement of the given AST with a new one, but only +-- if matches the given predicate. +replaceFinalStm :: Stm -> (Stm -> Bool) -> Stm -> TravM Stm +replaceFinalStm new p = go + where + go (Case c d as next) = Case c d as <$> go next + go (Forever s) = Forever <$> go s + go (Assign l r next) = Assign l r <$> go next + go s = return $ if p s then new else s + +-- | Returns statement's returned expression, if any. +finalExp :: Stm -> TravM (Maybe Exp) +finalExp stm = do + end <- finalStm stm + case end of + Return ex -> return $ Just ex + _ -> return Nothing + +class Pred a where + (.|.) :: a -> a -> a + (.&.) :: a -> a -> a + +instance Pred (a -> b -> Bool) where + {-# INLINE (.|.) #-} + {-# INLINE (.&.) #-} + 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 + {-# INLINE (.|.) #-} + {-# INLINE (.&.) #-} + p .|. q = \a -> p a || q a + p .&. q = \a -> p a && q a + +-- | Thunks and explicit lambdas count as lambda abstractions. +{-# INLINE isLambda #-} +isLambda :: ASTNode -> Bool +isLambda = isThunk .|. isFun + +{-# INLINE isThunk #-} +isThunk :: ASTNode -> Bool +isThunk (Exp (Thunk _ _) _) = True +isThunk _ = False + +{-# INLINE isFun #-} +isFun :: ASTNode -> Bool +isFun (Exp (Fun _ _) _) = True +isFun _ = False + +{-# INLINE isLoop #-} +isLoop :: ASTNode -> Bool +isLoop (Stm (Forever _) _) = True +isLoop _ = False + +{-# INLINE isConditional #-} +isConditional :: ASTNode -> Bool +isConditional (Exp _ cond) = cond +isConditional (Stm _ cond) = cond +isConditional _ = False + +{-# INLINE isShared #-} +isShared :: ASTNode -> Bool +isShared (Shared _) = True +isShared _ = False + +{-# INLINE isSafeForInlining #-} +isSafeForInlining :: ASTNode -> Bool +isSafeForInlining = not <$> isFun .|. isLoop .|. isShared + +-- | Counts occurrences. Use ints or something for a more exact count. +data Occs = Never | Once | Lots deriving (Eq, Show) + +instance Ord Occs where + {-# INLINE compare #-} + 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 + + Never - _ = Never + x - Never = x + Once - _ = Never + Lots - _ = Lots + + abs = id + + signum Never = Never + signum _ = Once + +-- | 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 + +-- | Replace all occurrences of an expression, without entering shared code +-- paths. IO ordering is preserved even when entering lambdas thanks to +-- State# RealWorld. +replaceExWithCount :: JSTrav ast + => (ASTNode -> Bool) -- ^ Which nodes to enter? + -> Exp -- ^ Expression to replace. + -> Exp -- ^ Replacement expression. + -> ast -- ^ AST to perform replacement on. + -> TravM (Int, ast) -- ^ New AST + count of replacements. +replaceExWithCount trav old new ast = + foldMapJS (const trav) rep (\count x -> return (count, x)) 0 ast + where + rep count ex + | ex == old = return (count+1, new) + | otherwise = return (count, ex) diff --git a/src/Haste/Builtins.hs b/src/Haste/Builtins.hs --- a/src/Haste/Builtins.hs +++ b/src/Haste/Builtins.hs @@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -- | Various functions generated as builtins module Haste.Builtins (toBuiltin) where -import GhcPlugins as P -import Data.JSTarget as J +import GhcPlugins as GHC +import Haste.AST as AST import Control.Applicative -- TODO: proxy# (and probably void#, realWorld# and coercionToken# as well) -- should really just go away in the final code. -toBuiltin :: P.Var -> Maybe J.Var +toBuiltin :: GHC.Var -> Maybe AST.Var toBuiltin v = case (modname, varname) of (Just "GHC.Prim", "coercionToken#") -> diff --git a/src/Haste/CodeGen.hs b/src/Haste/CodeGen.hs --- a/src/Haste/CodeGen.hs +++ b/src/Haste/CodeGen.hs @@ -9,7 +9,7 @@ import Data.Char import Data.List (partition, foldl') import Data.Maybe (isJust) -import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.UTF8 as BS import qualified Data.Set as S import qualified Data.Map as M @@ -19,8 +19,8 @@ import FastString (unpackFS) -- AST stuff -import Data.JSTarget as J hiding ((.&.)) -import Data.JSTarget.AST as J (Exp (..), Stm (..), LHS (..)) +import Haste.AST as AST hiding ((.&.)) +import Haste.AST.Syntax as AST (Exp (..), Stm (..), LHS (..), Lit (..)) -- General Haste stuff import Haste.Config @@ -30,17 +30,17 @@ import Haste.Builtins -- | Generate an abstract JS module from a codegen config and an STG module. -generate :: Config -> StgModule -> J.Module -generate cfg stg = - J.Module { - modPackageId = BS.fromString $ GHC.modPackageKey stg, - J.modName = BS.fromString $ GHC.modName stg, +generate :: Config -> ModMetadata -> [StgBinding] -> AST.Module +generate cfg meta stg = + AST.Module { + modPackageId = BS.fromString $ GHC.mmPackageKey meta, + AST.modName = BS.fromString $ GHC.mmName meta, modDeps = foldl' insDep M.empty theMod, modDefs = foldl' insFun M.empty theMod } where - opt = if optimize cfg then optimizeFun else const id - theMod = genAST cfg (GHC.modName stg) (modCompiledModule stg) + opt = if optimize cfg then optimizeFun cfg else const id + theMod = genAST cfg (GHC.mmName meta) stg insFun m (_, Assign (NewVar _ v@(Internal n _ _)) body _) = M.insert n (opt v body) m @@ -54,7 +54,7 @@ m -- | Generate JS AST for bindings. -genAST :: Config -> String -> [StgBinding] -> [(S.Set J.Name, Stm)] +genAST :: Config -> String -> [StgBinding] -> [(S.Set AST.Name, Stm)] genAST cfg modname binds = binds' where @@ -111,15 +111,20 @@ (True, [arg]) -> return $ evaluate arg (head stricts') _ -> mkCon tag args' stricts' where - mkInteger n = - array [litN 1, callForeign "I_fromBits" [array [lit lo, lit hi]]] + mkInteger n + | n < 0 = + callForeign "I_negate" [mkInteger (abs n)] + | otherwise = + litN 1 `conApp` [callForeign "I_fromBits" [lit lo, lit hi]] where lo = n .&. 0xffffffff hi = n `shiftR` 32 tooLarge n = n > 2147483647 || n < -2147483648 -- Always inline enum-likes, bools are true/false, not 1/0. - mkCon l _ _ | isEnumerationDataCon con = return l - mkCon tag as ss = return $ array (tag : zipWith evaluate as ss) + mkCon l _ _ + | isEnumerationDataCon con = return l + mkCon (AST.Lit (LNum 0)) [] [] = return zeroObject + mkCon tag as ss = return $ conApp tag (zipWith evaluate as ss) evaluate arg True = eval arg evaluate arg _ = arg genEx (StgOpApp op args _) = do @@ -185,13 +190,15 @@ -- 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 - continue $ newVar True v' expr + v' <- genVar v + pushBind v' + when (not onTopLevel) $ do + addLocal v' + expr <- genRhs isRecursive rhs + popBind + continue $ newVar (not isRecursive) v' expr + where + isRecursive = isJust funsInRecGroup genBind _ _ (StgRec _) = error $ "genBind got recursive bindings!" @@ -212,7 +219,7 @@ then thunk' upd (body' $ thunkRet retExp) else fun args' (body' $ ret retExp) where - thunk' _ (Return l@(J.Lit _)) = l + thunk' _ (Return l@(AST.Lit _)) = l thunk' Updatable stm = thunk True stm thunk' ReEntrant stm = thunk True stm thunk' SingleEntry stm = thunk False stm @@ -230,7 +237,7 @@ -- 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 :: [(GHC.Var, a)] -> JSGen Config ([J.Var], [a]) +genArgVarsPair :: [(GHC.Var, a)] -> JSGen Config ([AST.Var], [a]) genArgVarsPair vps = do vs' <- mapM genVar vs return (vs', xs) @@ -244,7 +251,7 @@ -- Return a scrutinee variable and a function to replace all occurrences of -- the STG scrutinee with our JS one, if needed. (scrut', withScrutinee) <- case ex' of - Eval (J.Var v) | overwriteScrutinees cfg -> do + Eval (AST.Var v) | overwriteScrutinees cfg -> do continue $ assignVar (reorderableType scrut) v ex' oldscrut <- genVar scrut return (v, rename oldscrut v) @@ -290,7 +297,6 @@ continue $ case_ scrutinee defAlt' alts' return (varExp res) where - getTag s = index s (litN 0) cmp = case t of PrimAlt _ -> id AlgAlt tc -> if isEnumerationTyCon tc then id else getTag @@ -310,7 +316,7 @@ isDefault (DEFAULT, _, _, _) = True isDefault _ = False -genAlt :: J.Var -> J.Var -> StgAlt -> JSGen Config (Exp, Stm -> Stm) +genAlt :: AST.Var -> AST.Var -> StgAlt -> JSGen Config (Exp, Stm -> Stm) genAlt scrut res (con, args, used, body) = do construct <- case con of -- undefined is intentional here - the first element is never touched. @@ -319,17 +325,17 @@ 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..]] + let binds = [bindVar v ix | (v, True, ix) <- zip3 args' used' [0::Int .. ]] (_, body') <- isolate $ do continue $ foldr (.) id binds retEx <- genEx body continue $ newVar False res retEx return $ construct body' where - bindVar v ix = newVar True v (index (varExp scrut) (litN ix)) + bindVar v = newVar True v . getField (varExp scrut) -- | Generate a result variable for the given scrutinee variable. -genResultVar :: GHC.Var -> JSGen Config J.Var +genResultVar :: GHC.Var -> JSGen Config AST.Var genResultVar v = do v' <- genVar v >>= getActualName case v' of @@ -340,7 +346,7 @@ -- | Generate a new variable and add a dependency on it to the function -- currently being generated. -genVar :: GHC.Var -> JSGen Config J.Var +genVar :: GHC.Var -> JSGen Config AST.Var genVar v | hasRepresentation v = do case toBuiltin v of Just v' -> return v' @@ -359,10 +365,10 @@ foreignName _ = error "Dynamic foreign calls not supported!" --- | Turn a 'GHC.Var' into a 'J.Var'. Falls back to a default module name, +-- | Turn a 'GHC.Var' into a 'AST.Var'. Falls back to a default module name, -- typically the name of the current module under compilation, if the given -- Var isn't qualified. -toJSVar :: String -> GHC.Var -> J.Var +toJSVar :: String -> GHC.Var -> AST.Var toJSVar thisMod v = case idDetails v of FCallId fc -> foreignVar (foreignName fc) @@ -484,7 +490,7 @@ where lo = n .&. 0xffffffff hi = n `shiftR` 32 - word64 n = callForeign "I_fromBits" [array [lit lo, lit hi]] + word64 n = callForeign "new Long" [lit lo, lit hi, lit True] where lo = n .&. 0xffffffff hi = n `shiftR` 32 diff --git a/src/Haste/Config.hs b/src/Haste/Config.hs --- a/src/Haste/Config.hs +++ b/src/Haste/Config.hs @@ -1,22 +1,24 @@ {-# LANGUAGE OverloadedStrings, Rank2Types, PatternGuards #-} module Haste.Config ( - Config (..), AppStart, def, stdJSLibs, startCustom, fastMultiply, - safeMultiply, debugLib) where -import Data.JSTarget + Config (..), AppStart, defaultConfig, stdJSLibs, startCustom, fastMultiply, + safeMultiply, strictly32Bits, debugLib) where +import Haste.AST.PP.Opts +import Haste.AST.Syntax +import Haste.AST.Constructors +import Haste.AST.Op import Control.Shell (replaceExtension, ()) import Data.ByteString.Builder import Data.Monoid import Haste.Environment import Outputable (Outputable) -import Data.Default import Data.List (stripPrefix, nub) type AppStart = Builder -> Builder stdJSLibs :: [FilePath] stdJSLibs = map (jsDir ) [ - "rts.js", "floatdecode.js", "stdlib.js", "endian.js", - "MVar.js", "StableName.js", "Integer.js", "Int64.js", "md5.js", "array.js", + "rts.js", "floatdecode.js", "stdlib.js", "endian.js", "bn.js", + "MVar.js", "StableName.js", "Integer.js", "long.js", "md5.js", "array.js", "pointers.js", "cheap-unicode.js", "Handle.js", "Weak.js", "Foreign.js" ] @@ -110,6 +112,10 @@ -- | Perform optimizations over the whole program at link time? wholeProgramOpts :: Bool, + -- | Perform comprehensive whole program flow analysis optimizations at + -- link time? + flowAnalysisOpts :: Bool, + -- | Allow the possibility that some tail recursion may not be optimized -- in order to gain slightly smaller code? sloppyTCE :: Bool, @@ -142,6 +148,27 @@ -- Defaults to True. optimize :: Bool, + -- | Enable tail loop transformation? + -- Defaults to True. + enableTailLoops :: Bool, + + -- | Enable proper tailcalls? + -- Defaults to True. + enableProperTailcalls :: Bool, + + -- | Inline @JSLit@ values? + -- Defaults to False. + inlineJSPrim :: Bool, + + -- | Remove tailcalls and trampolines for tail call cycles provably + -- shorter than @N@ calls. + -- Defaults to 3. + detrampolineThreshold :: Int, + + -- | Bound tail call chains at @n@ stack frames. + -- Defaults to 10. + tailChainBound :: Int, + -- | Overwrite scrutinees when evaluated instead of allocating a new local. -- Defaults to False. overwriteScrutinees :: Bool, @@ -159,18 +186,22 @@ -- | Emit @"use strict";@ declaration. Does not affect minification, but -- *does* affect any external JS. -- Defaults to True. - useStrict :: Bool + useStrict :: Bool, + + -- | Use classy objects for small ADTs? + -- Defaults to True. + useClassyObjects :: Bool } -- | Default compiler configuration. -defConfig :: Config -defConfig = Config { +defaultConfig :: Config +defaultConfig = Config { rtsLibs = stdJSLibs, libPaths = nub [jsmodUserDir, jsmodSysDir], targetLibPath = ".", appStart = startOnLoadComplete, wrapProg = False, - ppOpts = def, + ppOpts = defaultPPOpts, outFile = \cfg f -> let ext = if outputHTML cfg then "html" else "js" @@ -182,6 +213,7 @@ multiplyIntOp = safeMultiply, verbose = False, wholeProgramOpts = False, + flowAnalysisOpts = False, sloppyTCE = False, tracePrimops = False, useGoogleClosure = Nothing, @@ -191,11 +223,14 @@ showOutputable = const "No showOutputable defined in config!", mainMod = Just ("main", "Main"), optimize = True, + enableTailLoops = True, + enableProperTailcalls = True, + inlineJSPrim = False, + detrampolineThreshold = 3, + tailChainBound = 0, overwriteScrutinees = False, annotateExternals = False, annotateSymbols = False, - useStrict = True + useStrict = True, + useClassyObjects = True } - -instance Default Config where - def = defConfig diff --git a/src/Haste/Environment.hs b/src/Haste/Environment.hs --- a/src/Haste/Environment.hs +++ b/src/Haste/Environment.hs @@ -10,18 +10,20 @@ closureCompiler, bootFile, portableHaste, hasteNeedsReboot ) where -import System.IO.Unsafe +#if __GLASGOW_HASKELL__ <= 708 +import Control.Applicative +#endif +import Control.Shell import Data.Bits import Foreign.C.Types (CIntPtr) -import Control.Shell hiding (hClose) -import Paths_haste_compiler -import System.IO import System.Info -import Haste.GHCPaths (ghcPkgBinary, ghcBinary) -import Haste.Version +import System.IO.Unsafe #if defined(PORTABLE) import System.Environment (getExecutablePath) #endif +import Haste.GHCPaths (ghcPkgBinary, ghcBinary) +import Haste.Version +import Paths_haste_compiler -- | Subdirectory under Haste's root directory where all the stuff for this -- version lives. Use "windows" instead of "mingw32", since this is what @@ -149,18 +151,12 @@ #ifdef PORTABLE hasteNeedsReboot = False #else -hasteNeedsReboot = unsafePerformIO $ do - exists <- shell $ isFile bootFile - case exists of - Right True -> do - fh <- openFile bootFile ReadMode - bootedVerString <- hGetLine fh - hClose fh - case parseBootVersion bootedVerString of - Just (BootVer hasteVer ghcVer) -> - return $ hasteVer /= hasteVersion || ghcVer /= ghcVersion - _ -> - return True - _ -> do - return True +Right hasteNeedsReboot = unsafePerformIO . shell $ do + (guard (not <$> isFile bootFile) >> pure True) `orElse` do + bootedVerString <- withFile bootFile ReadMode hGetLine + case parseBootVersion bootedVerString of + Just (BootVer hasteVer ghcVer) -> + return $ hasteVer /= hasteVersion || ghcVer /= ghcVersion + _ -> + return True #endif diff --git a/src/Haste/Errors.hs b/src/Haste/Errors.hs --- a/src/Haste/Errors.hs +++ b/src/Haste/Errors.hs @@ -3,7 +3,7 @@ module Haste.Errors (runtimeError, warn, WarnLevel(..)) where import System.IO.Unsafe import System.IO -import Data.JSTarget +import Haste.AST import Haste.Monad import Haste.Config diff --git a/src/Haste/JSLib.hs b/src/Haste/JSLib.hs --- a/src/Haste/JSLib.hs +++ b/src/Haste/JSLib.hs @@ -7,7 +7,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.UTF8 as BS -import Data.JSTarget +import Haste.AST import System.Directory (doesFileExist) import System.IO diff --git a/src/Haste/Linker.hs b/src/Haste/Linker.hs --- a/src/Haste/Linker.hs +++ b/src/Haste/Linker.hs @@ -7,7 +7,7 @@ import qualified Data.Set as S import Control.Monad.State.Strict import Control.Monad.Trans.Either -import Data.JSTarget +import Haste.AST import qualified Data.ByteString.Lazy as B import qualified Data.ByteString as BS import Data.ByteString.UTF8 (toString, fromString) @@ -33,8 +33,10 @@ Just (m, p) -> (fromString m, fromString p) _ -> error "Haste.Linker.link called without main sym!" ds <- getAllDefs cfg (targetLibPath cfg : libPaths cfg) mainmod pkgid mainSym - let myDefs = if wholeProgramOpts cfg then topLevelInline ds else ds - (progText, myMain') = prettyProg (ppOpts cfg) mainSym myDefs + let myDefs = if wholeProgramOpts cfg + then topLevelInline cfg ds + else ds + (progText, myMain') = prettyProg cfg mainSym myDefs callMain = stringUtf8 "B(A(" <> myMain' <> stringUtf8 ", [0]));" launchApp = appStart cfg (stringUtf8 "hasteMain") diff --git a/src/Haste/Module.hs b/src/Haste/Module.hs --- a/src/Haste/Module.hs +++ b/src/Haste/Module.hs @@ -1,12 +1,11 @@ {-# LANGUAGE CPP #-} -- | Read and write JSMods. -module Haste.Module (writeModule, readModule) where +module Haste.Module (moduleFilePath, writeModule, readModule) where import Module (moduleNameSlashes, mkModuleName) import qualified Data.ByteString.Lazy as B import Control.Shell import Control.Applicative -import Control.Monad (when, filterM) -import Data.JSTarget +import Haste.AST import Data.Binary import Data.List (isSuffixOf) import qualified Data.ByteString.UTF8 as BS @@ -17,10 +16,14 @@ jsmodExt :: Bool -> String jsmodExt boot = if boot then "jsmod-boot" else "jsmod" -moduleFilePath :: FilePath -> String -> String -> Bool -> FilePath -moduleFilePath basepath pkgid modname boot = +-- | Build the path to the jsmod file corresponding to the given module. +moduleFilePath :: FilePath -- ^ Base path to look for module in. + -> String -- ^ Module name; e.g. @Foo.Bar@ + -> Bool -- ^ Build name for a boot module? + -> FilePath +moduleFilePath basepath modname boot = flip addExtension (jsmodExt boot) $ - basepath pkgid (moduleNameSlashes $ mkModuleName modname) + basepath moduleNameSlashes (mkModuleName modname) -- | Write a module to file, with the extension specified in `fileExt`. -- Assuming that fileExt = "jsmod", a module Foo.Bar is written to @@ -31,34 +34,37 @@ -- -- Boot modules and "normal" modules get merged at this stage. writeModule :: FilePath -> Module -> Bool -> IO () -writeModule basepath m@(Module pkgid modname _ _) boot = +writeModule basepath m@(Module _ modname _ _) boot = fromRight "writeModule" . shell $ do mkdir True (takeDirectory path) - mcompanion <- readMod basepath pkgstr modstr (not boot) + mcompanion <- readMod basepath modstr (not boot) m' <- case mcompanion of Just companion -> do - bootfileExists <- isFile bootpath - when bootfileExists $ rm bootpath + when (isFile bootpath) $ rm bootpath return $ merge' m companion - _ -> do + _ -> return m liftIO . B.writeFile path $ encode m' where - pkgstr = BS.toString pkgid modstr = BS.toString modname - path = moduleFilePath basepath pkgstr modstr boot - bootpath = moduleFilePath basepath pkgstr modstr True + path = moduleFilePath basepath modstr boot + bootpath = moduleFilePath basepath modstr True merge' = if boot then merge else flip merge -- | Read a module from file. If the module is not found at the specified path, -- libpath/path is tried instead. Returns Nothing is the module is not found -- on either path. +-- +-- This function first looks for an appropriate jslib file. If none is +-- found, then it looks for a standalone jsmod file, possibly with an +-- accompanying jsmod-boot file. If neither is found, it concludes that +-- the module simply does not exist on the given path and returns @Nothing@. readModule :: FilePath -> String -> String -> IO (Maybe Module) readModule basepath pkgid modname = fromRight "readModule" . shell $ do libfile <- (basepath ) `fmap` jslibFileName basepath pkgid mmlib <- liftIO $ JSLib.readModule libfile modname - mm <- readMod basepath pkgid modname False - mmboot <- readMod basepath pkgid modname True + mm <- readMod basepath modname False + mmboot <- readMod basepath modname True case (mmlib, mm, mmboot) of (Just m, _, _) -> return $ Just m (_, Just m, Nothing) -> return $ Just m @@ -112,8 +118,8 @@ specials = ["ghc-prim", "base", "integer-gmp"] libfilesuffix = pkgid <.> "jslib" -readMod :: FilePath -> String -> String -> Bool -> Shell (Maybe Module) -readMod basepath pkgid modname boot = do +readMod :: FilePath -> String -> Bool -> Shell (Maybe Module) +readMod basepath modname boot = do x <- isFile path let path' = if x then path else syspath isF <- isFile path' @@ -125,12 +131,13 @@ else do return Nothing where - path = moduleFilePath "." pkgid modname boot - syspath = moduleFilePath basepath pkgid modname boot + path = moduleFilePath "." modname boot + syspath = moduleFilePath basepath modname boot -fromRight :: String -> IO (Either String b) -> IO b +fromRight :: String -> IO (Either ExitReason b) -> IO b fromRight from m = do ex <- m case ex of Right x -> return x - Left e -> fail $ "shell expression failed in " ++ from ++ ": " ++ e + Left e -> fail $ "shell expression failed in " ++ from ++ ": " ++ + exitString e diff --git a/src/Haste/Monad.hs b/src/Haste/Monad.hs --- a/src/Haste/Monad.hs +++ b/src/Haste/Monad.hs @@ -5,7 +5,7 @@ pushBind, popBind, getCurrentBinding, whenCfg, rename, getActualName ) where import Control.Monad.State.Strict -import Data.JSTarget as J hiding (modName) +import Haste.AST as AST hiding (modName) import qualified Data.Set as S import Control.Applicative import qualified Data.Map as M @@ -49,7 +49,7 @@ -- | Mark a symbol as local, excluding it from the dependency graph. addLocal :: a -> JSGen cfg () -instance Dependency J.Name where +instance Dependency AST.Name where {-# INLINE dependOn #-} dependOn v = JSGen $ do st <- get @@ -60,7 +60,7 @@ st <- get put st {locals = v : locals st} -instance Dependency J.Var where +instance Dependency AST.Var where {-# INLINE dependOn #-} dependOn (Foreign _) = return () dependOn (Internal n _ _) = dependOn n @@ -80,7 +80,7 @@ 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, Stm -> Stm) + -> (a, S.Set AST.Name, S.Set AST.Name, Stm -> Stm) genJS cfg myModName (JSGen gen) = case runState gen (initialState cfg) {modName = myModName} of (a, GenState dependencies loc cont _ _ _ _) -> diff --git a/src/Haste/Opts.hs b/src/Haste/Opts.hs --- a/src/Haste/Opts.hs +++ b/src/Haste/Opts.hs @@ -2,8 +2,9 @@ import System.Console.GetOpt import Haste.Config import Haste.Environment -import Data.JSTarget.PP (PPOpts, withExtAnnotation, withAnnotations, withPretty, withHSNames) +import Haste.AST.PP.Opts import Data.List +import Data.Char (toLower) import Control.Shell (()) -- | Haste's command line options. The boolean indicates whether we're running @@ -20,8 +21,8 @@ "qualified Haskell names.", Option "" ["debug"] (NoArg $ \cfg -> cfg {ppOpts = debugPPOpts (ppOpts cfg)}) $ - "Output annotated, pretty-printed JavaScript code. Equivalent to " ++ - "--annotate-externals --annotate-symbols --pretty-print.", + "Output annotated, pretty-printed JavaScript code. Equivalent " ++ + "to --annotate-externals --annotate-symbols --pretty-print.", Option "" ["ddisable-js-opts"] (NoArg $ \cfg -> cfg {optimize = False}) $ "Don't perform any optimizations on the JavaScript at all. " ++ @@ -32,18 +33,18 @@ "Trace primops. Not really useful unless Haste was booted with " ++ "primop tracing enabled.", Option "" ["dont-link"] - (NoArg $ \cfg -> cfg {performLink = False}) $ + (NoArg $ \cfg -> cfg {performLink = False}) "Don't link generated .jsmod files into a .js blob.", Option "" ["full-unicode"] (NoArg fullUnicode) $ "Enable full generalCategory Unicode support. " ++ "May bloat output by upwards of 150 KB.", Option "?" ["help"] - (NoArg id) $ + (NoArg id) "Display this message.", Option "" ["link-jslib"] (OptArg (\file cfg -> cfg {linkJSLib = True, - linkJSLibFile = file}) "FILE") $ + linkJSLibFile = file}) "FILE") "Create a jslib file instead of an executable.", Option "" ["no-use-strict"] (NoArg $ \cfg -> cfg {useStrict = False}) $ @@ -60,26 +61,53 @@ "Shorthand for --start=onload.", Option "" ["opt-all"] (NoArg optAllSafe) $ - "Enable all safe optimizations. Equivalent to --opt-minify " ++ - "--opt-whole-program.", - Option "" ["opt-unsafe"] - (NoArg optAllUnsafe) $ - "Enable all optimizations, safe and unsafe. Equivalent to " ++ - "--opt-all --opt-unsafe-ints", + "Enable all safe optimizations except minification. Individual " ++ + "optimizations may be turned off using their individual flags.", + Option "" ["opt-anonymous-objects-only"] + (OptArg (setOpt (\x c -> c {useClassyObjects = not x})) "on/off") $ + "Only use anonymous objects to represent ADTs. Will make all " ++ + "programs slightly smaller, some programs slightly faster, and " ++ + "some programs a lot slower.", + Option "" ["opt-detrampoline-threshold"] + (ReqArg setDetrampolineThreshold "N") $ + "Remove trampolining and tail calls for provably finite tail " ++ + "call chains shorter than N calls. Set to 0 to disable entirely.", + Option "" ["opt-flow-analysis"] + (OptArg (setOpt (\x c -> c {flowAnalysisOpts = x})) "on/off") $ + "Enable whole program flow analysis. Highly experimental and " ++ + "possibly slow and/or incorrect. Don't use for now.", + Option "" ["opt-inline-ffi-primitives"] + (OptArg (setOpt (\x c -> c {inlineJSPrim = x})) "on/off") + "Inline FFI call primitives wherever possible.", Option "" ["opt-minify"] - (NoArg updateClosureCfg) $ + (OptArg (setOpt updateClosureCfg) "on/off") "Minify JavaScript output using Google Closure compiler.", Option "" ["opt-minify-flag"] (ReqArg updateClosureFlags "FLAG") $ "Pass a flag to Closure. " ++ "To minify programs in strict mode, use " ++ "--opt-minify-flag='--language_in=ECMASCRIPT5_STRICT'", + Option "" ["opt-proper-tailcalls"] + (OptArg (setOpt (\x c -> c {enableProperTailcalls=x})) "on/off") $ + "Use trampolining to implement proper tail calls. " ++ + "Enabled by default.", + Option "" ["opt-tail-chain-bound"] + (ReqArg setTailChainBound "N") + "Bound tailcall chains to N stack frames. Default is 1.", + Option "" ["opt-tail-loop-transform"] + (OptArg (setOpt (\x c -> c {enableTailLoops = x})) "on/off") $ + "Optimize tail recursive functions into loops when possible. " ++ + "Enabled by default.", + Option "" ["opt-unsafe"] + (NoArg optAllUnsafe) $ + "Enable all optimizations, safe and unsafe. Equivalent to " ++ + "--opt-all --opt-unsafe-ints", Option "" ["opt-unsafe-ints"] (NoArg unsafeMath) $ "Enable unsafe Int arithmetic. Implies --opt-unsafe-mult " ++ "--opt-vague-ints", Option "" ["opt-unsafe-mult"] - (NoArg unsafeMul) $ + (OptArg (setOpt unsafeMul) "on/off") $ "Use JavaScript's built-in multiplication operator for " ++ "fixed precision integer multiplication. This may speed " ++ "up Int multiplication by a factor of at least four, " @@ -88,24 +116,25 @@ ++ "which support Math.imul, this optimization will likely be " ++ "slower than the default.", Option "" ["opt-vague-ints"] - (NoArg vagueInts) $ + (OptArg (setOpt vagueInts) "on/off") $ "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.", Option "" ["opt-whole-program"] - (NoArg enableWholeProgramOpts) $ + (OptArg (setOpt enableWholeProgramOpts) "on/off") $ "Perform optimizations over the whole program during linking. " ++ "May significantly increase link time.", Option "" ["overwrite-scrutinees"] (NoArg $ \cfg -> cfg {overwriteScrutinees = True}) $ "Overwrite scrutinees when evaluated rather than allocating " ++ - "a new local for the evaluated value. This is largely experimental.", + "a new local for the evaluated value. This is largely " ++ + "experimental.", Option "o" ["out"] - (ReqArg (\f cfg -> cfg {outFile = \_ _ -> f}) "FILE") $ + (ReqArg (\f cfg -> cfg {outFile = \_ _ -> f}) "FILE") "Write JavaScript output to FILE.", Option "" ["outdir"] - (ReqArg (\d cfg -> cfg {targetLibPath = d}) "DIR") $ + (ReqArg (\d cfg -> cfg {targetLibPath = d}) "DIR") "Write intermediate files to DIR.", Option "" ["output-html"] (NoArg $ \cfg -> cfg {outputHTML = True}) $ @@ -121,23 +150,23 @@ "Preserve Haskell names in JavaScript code as far as possible. " ++ "Highly experimental and may break your code.", Option "" ["pretty-print"] - (NoArg $ \cfg -> cfg {ppOpts = withPretty (ppOpts cfg)}) $ + (NoArg $ \cfg -> cfg {ppOpts = withPretty (ppOpts cfg)}) "Pretty-print JavaScript output.", Option "" ["start"] (ReqArg (\start cfg -> cfg {appStart = startCustom start}) "CODE") $ - "Specify custom start code. '$HASTE_MAIN' will be replaced with " ++ - "the application's main function. For instance, " ++ + "Specify custom start code. '$HASTE_MAIN' will be replaced " ++ + "with the application's main function. For instance, " ++ "--start='$(\"foo\").onclick($HASTE_MAIN);' " ++ - "will use jQuery to launch the application whenever the element " ++ - "with the id \"foo\" is clicked.", + "will use jQuery to launch the application whenever the " ++ + "element with the id \"foo\" is clicked.", Option "" ["output-jsflow"] (NoArg enableJSFlow) $ "Output code for use with the JSFlow interpreter. Note that " ++ "this may leave your code crippled, since JSFlow doesn't " ++ "all of Haste's needs.", Option "v" ["verbose"] - (NoArg $ \cfg -> cfg {verbose = True}) $ + (NoArg $ \cfg -> cfg {verbose = True}) "Display even the most obnoxious warnings and messages.", Option "" ["with-js"] (ReqArg (\js c -> c {jsExternals = jsExternals c ++ commaBreak js}) @@ -173,29 +202,54 @@ (w, ws) -> w : commaBreak (drop 1 ws) -- | Don't wrap Ints. -vagueInts :: Config -> Config -vagueInts cfg = cfg {wrapIntMath = id} +vagueInts :: Bool -> Config -> Config +vagueInts True cfg = cfg {wrapIntMath = id} +vagueInts False cfg = cfg {wrapIntMath = strictly32Bits} -- | Use fast but unsafe multiplication. -unsafeMul :: Config -> Config -unsafeMul cfg = cfg {multiplyIntOp = fastMultiply} +unsafeMul :: Bool -> Config -> Config +unsafeMul True cfg = cfg {multiplyIntOp = fastMultiply} +unsafeMul False cfg = cfg {multiplyIntOp = safeMultiply} --- | Enable all unsafe math ops. Remember to update the info text when changing --- this! +-- | Enable all unsafe math ops. Remember to update the info text when +-- changing this! unsafeMath :: Config -> Config -unsafeMath = vagueInts . unsafeMul +unsafeMath = vagueInts True . unsafeMul True -- | Enable all optimizations, both safe and unsafe. optAllUnsafe :: Config -> Config -optAllUnsafe = optAllSafe . unsafeMath . enableWholeProgramOpts +optAllUnsafe = optAllSafe . unsafeMath -- | Enable all safe optimizations. optAllSafe :: Config -> Config -optAllSafe = enableWholeProgramOpts . updateClosureCfg +optAllSafe cfg = cfg { + wholeProgramOpts = True, + tailChainBound = 20, + detrampolineThreshold = 3, + inlineJSPrim = True, + enableProperTailcalls = True, + enableTailLoops = True, + optimize = True + } +-- | Set the tail call chain bound. +setTailChainBound :: String -> Config -> Config +setTailChainBound s cfg = + case reads s of + [(n, "")] -> cfg {tailChainBound = n} + _ -> cfg {tailChainBound = 0} + +-- | Set the call chain threshold for detrampolining. +setDetrampolineThreshold :: String -> Config -> Config +setDetrampolineThreshold s cfg = + case reads s of + [(n, "")] -> cfg {detrampolineThreshold = n} + _ -> cfg {detrampolineThreshold = 0} + -- | Set the path to the Closure compiler.jar to use. -updateClosureCfg :: Config -> Config -updateClosureCfg cfg = cfg {useGoogleClosure = Just closureCompiler} +updateClosureCfg :: Bool -> Config -> Config +updateClosureCfg True cfg = cfg {useGoogleClosure = Just closureCompiler} +updateClosureCfg False cfg = cfg {useGoogleClosure = Nothing} -- | Add flags for Google Closure to use updateClosureFlags :: String -> Config -> Config @@ -203,8 +257,24 @@ useGoogleClosureFlags = useGoogleClosureFlags cfg ++ commaBreak arg} -- | Enable optimizations over the entire program. -enableWholeProgramOpts :: Config -> Config -enableWholeProgramOpts cfg = cfg {wholeProgramOpts = True} +enableWholeProgramOpts :: Bool -> Config -> Config +enableWholeProgramOpts x cfg = cfg {wholeProgramOpts = x} + +-- | Set the value of an option with optional flags. +-- @--option@ means enable the option, as does +-- @--option=on|true|1|yes|enable@. +-- @--option=off|false|1|no|disable@ means to disable the option. +-- Flag arguments are case insensitive. +setOpt :: (Bool -> Config -> Config) -> Maybe String -> Config -> Config +setOpt set Nothing = set True +setOpt set (Just s) + | s' `elem` trueish = set True + | s' `elem` falseish = set False + | otherwise = error $ "Bad config flag boolean value: " ++ s + where + s' = map toLower s + trueish = ["on", "true", "1", "yes", "enable"] + falseish = ["off", "false", "0", "no", "disable"] -- | Produce output for the JSFlow interpreter. enableJSFlow :: Config -> Config diff --git a/src/Haste/PrimOps.hs b/src/Haste/PrimOps.hs --- a/src/Haste/PrimOps.hs +++ b/src/Haste/PrimOps.hs @@ -2,7 +2,7 @@ module Haste.PrimOps (genOp) where import Prelude hiding (LT, GT) import PrimOp -import Data.JSTarget +import Haste.AST import Haste.Config -- | Dummy State# RealWorld value for where one is needed. diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs --- a/src/Haste/Version.hs +++ b/src/Haste/Version.hs @@ -12,7 +12,7 @@ -- | Current Haste version. hasteVersion :: Version -hasteVersion = Version [0,5,2] [] +hasteVersion = Version [0,5,3] [] -- | Current Haste version as an Int. The format of this version number is -- MAJOR*10 000 + MINOR*100 + MICRO. diff --git a/src/haste-boot.hs b/src/haste-boot.hs --- a/src/haste-boot.hs +++ b/src/haste-boot.hs @@ -1,28 +1,23 @@ {-# LANGUAGE CPP #-} import Prelude hiding (read) -import Network.HTTP -import Network.Browser hiding (err) -import Network.URI -import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString as BS import Data.Version import Data.List (foldl') import Data.Maybe (fromJust) import Codec.Compression.BZip import Codec.Archive.Tar -import System.Environment (getArgs) -import System.Exit -import Control.Monad import Haste.Environment import Haste.Version import Control.Shell +import Control.Shell.Concurrent +import Control.Shell.Download import Data.Char (isDigit) -import Control.Monad.IO.Class (liftIO) import Haste.Args import System.Console.GetOpt import GHC.Paths (libdir) import System.Info (os) import System.Directory (copyPermissions) -import System.FilePath (takeDirectory) #if __GLASGOW_HASKELL__ >= 710 ghcMajor = "7.10" @@ -34,20 +29,6 @@ primVersion = "0.3.0.0" #endif -downloadFile :: String -> Shell BS.ByteString -downloadFile f = do - (_, rsp) <- liftIO $ Network.Browser.browse $ do - setAllowRedirects True - request $ Request { - rqURI = fromJust $ parseURI f, - rqMethod = GET, - rqHeaders = [], - rqBody = BS.empty - } - case rspCode rsp of - (2, _, _) -> return $ rspBody rsp - _ -> fail $ "Failed to download " ++ f ++ ": " ++ rspReason rsp - data Cfg = Cfg { getLibs :: Bool, getClosure :: Bool, @@ -159,26 +140,21 @@ data CabalOp = Configure | Build | Install | Clean main :: IO () -main = do - args <- getArgs - when ("--help" `elem` args || "-?" `elem` args) $ do - putStrLn $ printHelp hdr specs - exitSuccess +main = shell_ $ do + when ("--help" `elem` cmdline || "-?" `elem` cmdline) $ do + echo $ printHelp hdr specs + exit - case getOpt Permute specs args of + case getOpt Permute specs cmdline of (cfgs, [], []) -> do let cfg = foldl' (flip (.)) id cfgs defCfg when (hasteNeedsReboot || forceBoot cfg) $ do - res <- shell $ if useLocalLibs cfg - then bootHaste cfg "." - else withTempDirectory "haste" $ bootHaste cfg - case res of - Right _ -> return () - Left err -> putStrLn err >> exitFailure - (cfgs, nonopts, errs) -> do - mapM_ putStr errs - mapM_ (\x -> putStrLn $ "unrecognized option `" ++ x ++ "'") nonopts - exitFailure + if useLocalLibs cfg + then bootHaste cfg "." + else withTempDirectory "haste" $ bootHaste cfg + (cfgs, nopts, errs) -> do + let errors = errs ++ map (\x -> "unrecognized option `" ++ x ++ "'") nopts + fail $ unlines errors bootHaste :: Cfg -> FilePath -> Shell () bootHaste cfg tmpdir = @@ -195,6 +171,9 @@ when (getHasteCabal cfg) $ do installHasteCabal portableHaste tmpdir + -- Spawn off closure download in the background. + closure <- future $ when (getClosure cfg) installClosure + when (not $ useLocalLibs cfg) $ do fetchLibs tmpdir @@ -209,10 +188,12 @@ "deepseq", "dlist", "haste-prim", "time", "haste-lib", "monads-tf", "old-locale", "transformers", "integer-gmp"] - when (getClosure cfg) $ do - installClosure - file bootFile (showBootVersion bootVersion) + -- Wait for closure download to finish. + await closure + + output bootFile (showBootVersion bootVersion) + clearDir :: FilePath -> Shell () clearDir dir = do exists <- isDirectory dir @@ -221,7 +202,7 @@ installHasteCabal :: Bool -> FilePath -> Shell () installHasteCabal portable tmpdir = do echo "Downloading haste-cabal from GitHub" - f <- decompress `fmap` downloadFile hasteCabalUrl + f <- (decompress . BSL.fromChunks . (:[])) `fmap` fetchBytes hasteCabalUrl if os == "linux" then do mkdir True hasteCabalRootDir @@ -229,9 +210,9 @@ liftIO $ copyPermissions hasteBinary (hasteCabalRootDir "haste-cabal/haste-cabal.bin") - file (hasteBinDir hasteCabalFile) launcher + output (hasteBinDir hasteCabalFile) launcher else do - liftIO $ BS.writeFile (hasteBinDir hasteCabalFile) f + liftIO $ BSL.writeFile (hasteBinDir hasteCabalFile) f liftIO $ copyPermissions hasteBinary (hasteBinDir hasteCabalFile) where baseUrl = "http://valderman.github.io/haste-libs/" @@ -265,8 +246,8 @@ fetchLibs :: FilePath -> Shell () fetchLibs tmpdir = do echo "Downloading base libs from GitHub" - file <- downloadFile $ mkUrl hasteVersion - liftIO . unpack tmpdir . read . decompress $ file + file <- fetchBytes $ mkUrl hasteVersion + liftIO . unpack tmpdir . read . decompress $ BSL.fromChunks [file] where mkUrl v = "http://valderman.github.io/haste-libs/haste-libs-" ++ showVersion v ++ ".tar.bz2" @@ -279,7 +260,7 @@ echo "Couldn't install Closure compiler; continuing without." where downloadClosure = do - downloadFile closureURI >>= (liftIO . BS.writeFile closureCompiler) + fetchBytes closureURI >>= (liftIO . BS.writeFile closureCompiler) closureURI = "http://valderman.github.io/haste-libs/compiler.jar" @@ -288,7 +269,7 @@ buildLibs cfg = do -- Set up dirs and copy includes mkdir True $ pkgSysLibDir - cpDir "include" hasteSysDir + cpdir "include" hasteSysDir inDirectory ("utils" "unlit") $ do let out = if os == "mingw32" then "unlit.exe" else "unlit" @@ -348,6 +329,7 @@ else takeDirectory pkgSysLibDir , "--package-db=clear" , "--package-db=global" + , "--hastec-option=-fforce-recomp" #if __GLASGOW_HASKELL__ < 709 , "--hastec-option=-DHASTE_HOST_WORD_SIZE_IN_BITS=" ++ show hostWordSize diff --git a/src/haste-cat.hs b/src/haste-cat.hs --- a/src/haste-cat.hs +++ b/src/haste-cat.hs @@ -3,8 +3,8 @@ import System.Environment import Haste.Module import Haste.Config -import Data.JSTarget -import Data.JSTarget.PP +import Haste.AST +import Haste.AST.PP import Data.Maybe import qualified Data.Map as M import qualified Data.ByteString.Lazy.Char8 as BSL @@ -18,7 +18,7 @@ printModule mpkg = do let (pkg, (_:mn)) = break (== ':') mpkg - paths = "." : libPaths def + paths = "." : libPaths defaultConfig mods <- mapM (\p -> (p, ) `fmap` readModule p pkg mn) paths case filter (isJust . snd) mods of ((p, Just m):_) -> printDefs p pkg mn m @@ -33,8 +33,11 @@ mapM_ printDef $ M.toList $ modDefs m printDef (name, d) = do + let cfg = defaultConfig { + ppOpts = withPretty . withExtAnnotation $ withAnnotations defaultPPOpts + } BS.putStrLn $ niceName name - BSL.putStrLn $ pretty (withPretty . withExtAnnotation $ withAnnotations def) d + BSL.putStrLn $ pretty cfg d putStrLn "" niceName (Name n (Just (pkg, m))) = diff --git a/src/hastec.hs b/src/hastec.hs --- a/src/hastec.hs +++ b/src/hastec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} -- | Haste's main compiler driver. module Main where -import Language.Haskell.GHC.Simple +import Language.Haskell.GHC.Simple as GHC #if __GLASGOW_HASKELL__ >= 710 import Language.Haskell.GHC.Simple.PrimIface import Packages @@ -9,6 +9,7 @@ #endif import GHC import Outputable (showPpr) +import Platform import System.Environment (getArgs, lookupEnv, setEnv) import System.Exit @@ -28,6 +29,7 @@ import Haste.Version import Haste.Module import Haste.CodeGen +import Haste.AST as AST (Module) import Haste.Linker import Haste.JSLib @@ -45,13 +47,14 @@ case parseHasteFlags booting args as of Left act -> act Right (fs, mkConfig) -> do - let ghcconfig = mkGhcCfg fs args - (dfs, _) <- getDynFlagsForConfig ghcconfig + let hastecfg = mkConfig Haste.Config.defaultConfig + ghccfg = mkGhcCfg hastecfg fs args + (dfs, _) <- getDynFlagsForConfig ghccfg extralibdirs <- getExtraLibDirs dfs let cfg = mkLinkerCfg dfs extralibdirs . setShowOutputable dfs - $ mkConfig def - res <- compileFold ghcconfig (compJS cfg) ([], []) [] + $ hastecfg + res <- compileFold ghccfg (compJSMod cfg) finalize ([], []) [] case res of Failure _ _ -> do exitFailure @@ -67,9 +70,6 @@ getExtraLibDirs = const (return []) #endif - dotToSlash '.' = '/' - dotToSlash c = c - pkgs booting = ["-no-global-package-db", "-no-user-package-db", @@ -79,9 +79,8 @@ else ["-package-db=" ++ pkgUserDir] buildJSLib profiling cfg pkgkey mods = do - let modpath = targetLibPath cfg ++ "/" ++ pkgkey - mods' = [ modpath ++ "/" ++ map dotToSlash mn ++ ".jsmod" - | mn <- mods] + let targetpath = targetLibPath cfg + mods' = [moduleFilePath targetpath mn False | mn <- mods] libfile = maybe (pkgkey <.> "jsmod") id (linkJSLibFile cfg) profLibfile = reverse (drop 6 (reverse libfile)) ++ "_p.jslib" @@ -89,25 +88,39 @@ when profiling . void $ do copyFile libfile (profLibfile) - compJS cfg (targets, mods) m = do - compJSMod cfg m - let infile = maybe (modInterfaceFile m) id (modSourceFile m) - modpair = (modPackageKey m, infile) + finalize (targets, mods) m = do + let meta = modMetadata m + infile = maybe (mmInterfaceFile meta) id (mmSourceFile meta) + modpair = (mmPackageKey meta, infile) if modIsTarget m - then return $ (modpair : targets, modName m : mods) - else return (targets, modName m : mods) + then return (modpair : targets, mmName meta : mods) + else return (targets, mmName meta : mods) - mkGhcCfg fs args = defaultConfig { + mkGhcCfg cfg fs args = disableCodeGen $ GHC.defaultConfig { cfgGhcFlags = fs, cfgGhcLibDir = Just hasteGhcLibDir, cfgUseTargetsFromFlags = True, cfgUseGhcErrorLogger = True, + cfgCacheDirectory = Just $ targetLibPath cfg, + cfgCacheFileExt = "jsmod", cfgUpdateDynFlags = \dfs -> dfs { - ghcLink = NoLink, ghcMode = if "-c" `elem` args then OneShot else CompManager, - hscTarget = HscAsm + settings = (settings dfs) { + sTargetPlatform = (sTargetPlatform $ settings dfs) { + platformArch = ArchX86, + platformWordSize = 4 + }, + sPlatformConstants = (sPlatformConstants $ settings dfs) { + pc_WORD_SIZE = 4, + pc_CINT_SIZE = 4, + pc_CLONG_SIZE = 4, + pc_CLONG_LONG_SIZE = 8, + pc_DOUBLE_SIZE = 8, + pc_WORDS_BIGENDIAN = False + } + } } #if __GLASGOW_HASKELL__ >= 710 , cfgCustomPrimIface = Just (primOpInfo, primOpStrictness) @@ -132,13 +145,13 @@ -- | Compile an STG module into a JS module and write it to its appropriate -- location according to the given config. -compJSMod :: Config -> StgModule -> IO () -compJSMod cfg stg = do +compJSMod :: Config -> ModMetadata -> [StgBinding] -> IO AST.Module +compJSMod cfg meta stg = do logStr cfg $ "Compiling " ++ myName ++ " into " ++ targetpath - writeModule targetpath (generate cfg stg) boot + return $ generate cfg meta stg where - boot = modSourceIsHsBoot stg - myName = modName stg ++ if boot then " [boot]" else "" + boot = mmSourceIsHsBoot meta + myName = mmName meta ++ if boot then " [boot]" else "" targetpath = targetLibPath cfg -- | Link a program starting from the 'mainMod' symbol of the given 'Config'. @@ -152,13 +165,13 @@ _ -> return () when (outputHTML cfg) $ do res <- Sh.shell $ Sh.withCustomTempFile "." $ \tmp h -> do - prog <- Sh.file outfile + prog <- Sh.input outfile Sh.hPutStrLn h (htmlSkeleton outfile prog) Sh.liftIO $ hClose h Sh.mv tmp outfile case res of Right () -> return () - Left err -> error $ "Couldn't output HTML file: " ++ err + Left err -> error $ "Couldn't output HTML file: " ++ Sh.exitString err where outfile = outFile cfg cfg infile @@ -184,10 +197,11 @@ "--compilation_level", "ADVANCED_OPTIMIZATIONS", "--jscomp_off", "globalThis", f] ++ arguments) "" - Sh.file cloFile str :: Sh.Shell () + Sh.output cloFile str Sh.mv cloFile f case res of - Left e -> fail $ "Couldn't execute Google Closure compiler: " ++ e + Left e -> fail $ "Couldn't execute Google Closure compiler: " ++ + Sh.exitString e Right _ -> return () -- | Call vanilla GHC; used for C files and the like.