haste-compiler 0.5.2 → 0.5.3
raw patch · 56 files changed
+4999/−3552 lines, 56 filesdep −data-defaultdep ~ghc-simpledep ~shellmate
Dependencies removed: data-default
Dependency ranges changed: ghc-simple, shellmate
Files
- haste-compiler.cabal +20/−21
- lib/Foreign.js +8/−6
- lib/Int64.js +0/−458
- lib/Integer.js +66/−500
- lib/MVar.js +2/−2
- lib/Weak.js +2/−2
- lib/bn.js +1460/−0
- lib/floatdecode.js +7/−4
- lib/long.js +341/−0
- lib/rts.js +104/−33
- lib/stdlib.js +14/−14
- libraries/haste-lib/src/Haste/Binary.hs +1/−1
- libraries/haste-lib/src/Haste/Binary/Types.hs +10/−1
- libraries/haste-lib/src/Haste/Compiler.hs +8/−8
- libraries/haste-lib/src/Haste/DOM.hs +1/−1
- libraries/haste-lib/src/Haste/DOM/Core.hs +10/−7
- libraries/haste-lib/src/Haste/DOM/JSString.hs +1/−1
- libraries/haste-lib/src/Haste/Events/Core.hs +2/−2
- libraries/haste-lib/src/Haste/Graphics/Canvas.hs +8/−6
- libraries/haste-lib/src/Haste/Hash.hs +2/−1
- src/Data/JSTarget.hs +0/−17
- src/Data/JSTarget/AST.hs +0/−194
- src/Data/JSTarget/Binary.hs +0/−155
- src/Data/JSTarget/Constructors.hs +0/−185
- src/Data/JSTarget/Op.hs +0/−85
- src/Data/JSTarget/Optimize.hs +0/−773
- src/Data/JSTarget/PP.hs +0/−224
- src/Data/JSTarget/Print.hs +0/−275
- src/Data/JSTarget/Traversal.hs +0/−344
- src/Haste.hs +0/−8
- src/Haste/AST.hs +17/−0
- src/Haste/AST/Binary.hs +159/−0
- src/Haste/AST/Constructors.hs +201/−0
- src/Haste/AST/FlowAnalysis.hs +170/−0
- src/Haste/AST/Op.hs +86/−0
- src/Haste/AST/Optimize.hs +849/−0
- src/Haste/AST/PP.hs +190/−0
- src/Haste/AST/PP/Opts.hs +47/−0
- src/Haste/AST/Print.hs +307/−0
- src/Haste/AST/Syntax.hs +214/−0
- src/Haste/AST/Traversal.hs +353/−0
- src/Haste/Builtins.hs +3/−3
- src/Haste/CodeGen.hs +40/−34
- src/Haste/Config.hs +49/−14
- src/Haste/Environment.hs +16/−20
- src/Haste/Errors.hs +1/−1
- src/Haste/JSLib.hs +1/−1
- src/Haste/Linker.hs +5/−3
- src/Haste/Module.hs +29/−22
- src/Haste/Monad.hs +4/−4
- src/Haste/Opts.hs +108/−38
- src/Haste/PrimOps.hs +1/−1
- src/Haste/Version.hs +1/−1
- src/haste-boot.hs +31/−49
- src/haste-cat.hs +7/−4
- src/hastec.hs +43/−29
haste-compiler.cabal view
@@ -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,
lib/Foreign.js view
@@ -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; }
− lib/Int64.js
@@ -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));-}
lib/Integer.js view
@@ -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; }
lib/MVar.js view
@@ -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}; } }
lib/Weak.js view
@@ -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))}; }
+ lib/bn.js view
@@ -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);
lib/floatdecode.js view
@@ -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}; }
+ lib/long.js view
@@ -0,0 +1,341 @@+/**+ * @license long.js (c) 2013 Daniel Wirtz <dcode@dcode.io>+ * 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();}
lib/rts.js view
@@ -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) {
lib/stdlib.js view
@@ -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) */
libraries/haste-lib/src/Haste/Binary.hs view
@@ -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
libraries/haste-lib/src/Haste/Binary/Types.hs view
@@ -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
libraries/haste-lib/src/Haste/Compiler.hs view
@@ -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
libraries/haste-lib/src/Haste/DOM.hs view
@@ -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,
libraries/haste-lib/src/Haste/DOM/Core.hs view
@@ -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
libraries/haste-lib/src/Haste/DOM/JSString.hs view
@@ -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,
libraries/haste-lib/src/Haste/Events/Core.hs view
@@ -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 #-}
libraries/haste-lib/src/Haste/Graphics/Canvas.hs view
@@ -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
libraries/haste-lib/src/Haste/Hash.hs view
@@ -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 ()
− src/Data/JSTarget.hs
@@ -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)
− src/Data/JSTarget/AST.hs
@@ -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
− src/Data/JSTarget/Binary.hs
@@ -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]
− src/Data/JSTarget/Constructors.hs
@@ -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
− src/Data/JSTarget/Op.hs
@@ -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
− src/Data/JSTarget/Optimize.hs
@@ -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
− src/Data/JSTarget/PP.hs
@@ -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 ()
− src/Data/JSTarget/Print.hs
@@ -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
− src/Data/JSTarget/Traversal.hs
@@ -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)
− src/Haste.hs
@@ -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)
+ src/Haste/AST.hs view
@@ -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
+ src/Haste/AST/Binary.hs view
@@ -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]
+ src/Haste/AST/Constructors.hs view
@@ -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
+ src/Haste/AST/FlowAnalysis.hs view
@@ -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']}
+ src/Haste/AST/Op.hs view
@@ -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
+ src/Haste/AST/Optimize.hs view
@@ -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
+ src/Haste/AST/PP.hs view
@@ -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 ()
+ src/Haste/AST/PP/Opts.hs view
@@ -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}
+ src/Haste/AST/Print.hs view
@@ -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
+ src/Haste/AST/Syntax.hs view
@@ -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
+ src/Haste/AST/Traversal.hs view
@@ -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)
src/Haste/Builtins.hs view
@@ -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#") ->
src/Haste/CodeGen.hs view
@@ -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
src/Haste/Config.hs view
@@ -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
src/Haste/Environment.hs view
@@ -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
src/Haste/Errors.hs view
@@ -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
src/Haste/JSLib.hs view
@@ -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
src/Haste/Linker.hs view
@@ -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")
src/Haste/Module.hs view
@@ -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
src/Haste/Monad.hs view
@@ -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 _ _ _ _) ->
src/Haste/Opts.hs view
@@ -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
src/Haste/PrimOps.hs view
@@ -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.
src/Haste/Version.hs view
@@ -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.
src/haste-boot.hs view
@@ -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
src/haste-cat.hs view
@@ -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))) =
src/hastec.hs view
@@ -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.