diff --git a/haste-compiler.cabal b/haste-compiler.cabal --- a/haste-compiler.cabal +++ b/haste-compiler.cabal @@ -1,5 +1,5 @@ Name: haste-compiler -Version: 0.4.2 +Version: 0.4.2.1 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler @@ -62,6 +62,7 @@ bzlib, transformers, network, + network-uri, HTTP, shellmate >= 0.1.5, ghc-paths, @@ -235,7 +236,6 @@ binary, data-binary-ieee754, bytestring >= 0.9.2.1, - websockets >= 0.8, utf8-string, -- For Haste.Compiler shellmate >= 0.1.5, @@ -246,4 +246,13 @@ ghc-paths, ghc, directory + -- websockets-0.9 is broken on Windows + if os(windows) + Build-Depends: + websockets >= 0.8 && < 0.9, + network < 2.6, + network-uri < 2.6 + else + Build-Depends: + websockets >= 0.8 Default-Language: Haskell98 diff --git a/lib/rts.js b/lib/rts.js --- a/lib/rts.js +++ b/lib/rts.js @@ -69,21 +69,24 @@ function E(t) { if(t instanceof T) { if(t.f instanceof F) { - return t.f = t.f.f(); - } else { - return t.f; + var f = t.f.f; + t.f = 0; + t.f = f(); } + return t.f; } else { return t; } } /* Bounce - Bonuce on a trampoline for as long as we get a function back. + Bounce on a trampoline for as long as we get a function back. */ function B(f) { while(f instanceof F) { - f = f.f(); + var fun = f.f; + f = 0; + f = fun(); } return f; } @@ -117,12 +120,16 @@ // 32 bit integer multiplication, with correct overflow behavior // note that |0 or >>>0 needs to be applied to the result, for int and word // respectively. -function imul(a, b) { - // ignore high a * high a as the result will always be truncated - var lows = (a & 0xffff) * (b & 0xffff); // low a * low b - var aB = (a & 0xffff) * (b & 0xffff0000); // low a * high b - var bA = (a & 0xffff0000) * (b & 0xffff); // low b * high a - return lows + aB + bA; // sum will not exceed 52 bits, so it's safe +if(Math.imul) { + var imul = Math.imul; +} else { + var imul = function(a, b) { + // ignore high a * high a as the result will always be truncated + var lows = (a & 0xffff) * (b & 0xffff); // low a * low b + var aB = (a & 0xffff) * (b & 0xffff0000); // low a * high b + var bA = (a & 0xffff0000) * (b & 0xffff); // low b * high a + return lows + aB + bA; // sum will not exceed 52 bits, so it's safe + } } function addC(a, b) { @@ -254,11 +261,11 @@ function localeEncoding() { var le = newByteArr(5); - le['b']['i8'] = 'U'.charCodeAt(0); - le['b']['i8'] = 'T'.charCodeAt(0); - le['b']['i8'] = 'F'.charCodeAt(0); - le['b']['i8'] = '-'.charCodeAt(0); - le['b']['i8'] = '8'.charCodeAt(0); + le['v']['i8'][0] = 'U'.charCodeAt(0); + le['v']['i8'][1] = 'T'.charCodeAt(0); + le['v']['i8'][2] = 'F'.charCodeAt(0); + le['v']['i8'][3] = '-'.charCodeAt(0); + le['v']['i8'][4] = '8'.charCodeAt(0); return le; } diff --git a/libraries/haste-lib/src/Haste/Binary.hs b/libraries/haste-lib/src/Haste/Binary.hs --- a/libraries/haste-lib/src/Haste/Binary.hs +++ b/libraries/haste-lib/src/Haste/Binary.hs @@ -1,7 +1,9 @@ {-# LANGUAGE MagicHash, CPP, MultiParamTypeClasses, OverloadedStrings, TypeSynonymInstances , FlexibleInstances, OverlappingInstances, - GeneralizedNewtypeDeriving #-} + GeneralizedNewtypeDeriving, BangPatterns, TypeOperators, KindSignatures, DefaultSignatures, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, ScopedTypeVariables #-} -- | Handling of Javascript-native binary blobs. +-- +-- Generics borrowed from the binary package by Lennart Kolmodin (released under BSD3) module Haste.Binary ( module Haste.Binary.Put, module Haste.Binary.Get, @@ -20,6 +22,8 @@ import Haste.Binary.Put import Haste.Binary.Get import Control.Applicative +import GHC.Generics +import Data.Bits class Monad m => MonadBlob m where -- | Retrieve the raw data from a blob. @@ -43,7 +47,7 @@ #else mkBlobData = undefined #endif - + convertBlob :: Blob -> Opaque (Unpacked -> IO ()) -> IO () convertBlob = ffi "(function(b,cb){var r=new FileReader();r.onload=function(){B(A(cb,[new DataView(r.result),0]));};r.readAsArrayBuffer(b);})" @@ -65,6 +69,17 @@ get :: Get a put :: a -> Put + default put :: (Generic a, GBinary (Rep a)) => a -> Put + put = gput . from + + default get :: (Generic a, GBinary (Rep a)) => Get a + get = to `fmap` gget + +-- | Generic version +class GBinary f where + gput :: f t -> Put + gget :: Get (f t) + instance Binary Word8 where put = putWord8 get = getWord8 @@ -160,3 +175,112 @@ decode :: Binary a => BlobData -> Either String a decode = runGet get + + +-- Type without constructors +instance GBinary V1 where + gput _ = return () + gget = return undefined + +-- Constructor without arguments +instance GBinary U1 where + gput U1 = return () + gget = return U1 + +-- Product: constructor with parameters +instance (GBinary a, GBinary b) => GBinary (a :*: b) where + gput (x :*: y) = gput x >> gput y + gget = (:*:) <$> gget <*> gget + +-- Metadata (constructor name, etc) +instance GBinary a => GBinary (M1 i c a) where + gput = gput . unM1 + gget = M1 <$> gget + +-- Constants, additional parameters, and rank-1 recursion +instance Binary a => GBinary (K1 i a) where + gput = put . unK1 + gget = K1 <$> get + +-- Borrowed from the cereal package. + +-- The following GBinary instance for sums has support for serializing +-- types with up to 2^64-1 constructors. It will use the minimal +-- number of bytes needed to encode the constructor. For example when +-- a type has 2^8 constructors or less it will use a single byte to +-- encode the constructor. If it has 2^16 constructors or less it will +-- use two bytes, and so on till 2^64-1. +-- +-- NB: changed to 2^32-1 constructors + +#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) +#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) +#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) + +instance ( GSum a, GSum b + , GBinary a, GBinary b + , SumSize a, SumSize b) => GBinary (a :+: b) where + gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) -- | PUTSUM(Word64) + | otherwise = sizeError "encode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word32) + {-# INLINE gput #-} + + gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) -- | GETSUM(Word64) + | otherwise = sizeError "decode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word32) + {-# INLINE gget #-} + +sizeError :: Show size => String -> size -> error +sizeError s size = + error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" + +------------------------------------------------------------------------ + +checkGetSum :: (Ord word, Num word, Bits word, GSum f) + => word -> word -> Get (f a) +checkGetSum size code | code < size = getSum code size + | otherwise = fail "Unknown encoding for constructor" +{-# INLINE checkGetSum #-} + +class GSum f where + getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) + putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put + +instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where + getSum !code !size | code < sizeL = L1 <$> getSum code sizeL + | otherwise = R1 <$> getSum (code - sizeL) sizeR + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE getSum #-} + + putSum !code !size s = case s of + L1 x -> putSum code sizeL x + R1 x -> putSum (code + sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE putSum #-} + +instance GBinary a => GSum (C1 c a) where + getSum _ _ = gget + {-# INLINE getSum #-} + + putSum !code _ x = put code *> gput x + {-# INLINE putSum #-} + +------------------------------------------------------------------------ + +class SumSize f where + sumSize :: Tagged f Word32 + +newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a Word32) + + unTagged (sumSize :: Tagged b Word32) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/src/Data/JSTarget.hs b/src/Data/JSTarget.hs --- a/src/Data/JSTarget.hs +++ b/src/Data/JSTarget.hs @@ -4,7 +4,7 @@ PPOpts (..), pretty, runPP, prettyProg, def, Arity, Comment, Shared, Name (..), Var (..), LHS, Call, Lit, Exp, Stm, Alt, AST (..), Module (..), - foreignModule, moduleOf, pkgOf, blackHole, blackHoleVar + foreignModule, moduleOf, pkgOf, blackHole, blackHoleVar, merge ) where import Data.JSTarget.AST import Data.JSTarget.Op as Op diff --git a/src/Data/JSTarget/AST.hs b/src/Data/JSTarget/AST.hs --- a/src/Data/JSTarget/AST.hs +++ b/src/Data/JSTarget/AST.hs @@ -1,7 +1,11 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances, CPP #-} 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 System.IO.Unsafe import System.Random (randomIO) import Data.IORef @@ -16,7 +20,7 @@ -- | Shared statements. newtype Shared a = Shared Lbl deriving (Eq, Show) -data Name = Name String (Maybe (String, String)) deriving (Eq, Ord, Show) +data Name = Name !String !(Maybe (String, String)) deriving (Eq, Ord, Show) class HasModule a where moduleOf :: a -> Maybe String @@ -34,8 +38,8 @@ -- | Representation of variables. data Var where - Foreign :: String -> Var - Internal :: Name -> Comment -> Var + Foreign :: !String -> Var + Internal :: !Name -> !Comment -> Var deriving (Show) instance Eq Var where @@ -53,8 +57,8 @@ -- but for some primops we need to assign array elements as well. -- LhsExp is never reorderable. data LHS where - NewVar :: Reorderable -> Var -> LHS - LhsExp :: Exp -> LHS + NewVar :: !Reorderable -> !Var -> LHS + LhsExp :: !Exp -> LHS deriving (Eq, Show) -- | Distinguish between normal, optimized and method calls. @@ -63,48 +67,48 @@ -- 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 :: String -> Call + Normal :: !Bool -> Call + Fast :: !Bool -> Call + Method :: !String -> Call deriving (Eq, Show) -- | Literals; nothing fancy to see here. data Lit where - LNum :: Double -> Lit - LStr :: String -> Lit - LBool :: Bool -> Lit - LInt :: Integer -> Lit + LNum :: !Double -> Lit + LStr :: !String -> Lit + LBool :: !Bool -> Lit + LInt :: !Integer -> Lit LNull :: Lit deriving (Eq, Show) -- | Expressions. Completely predictable. data Exp where - Var :: Var -> Exp - Lit :: Lit -> Exp - Not :: Exp -> Exp - BinOp :: BinOp -> Exp -> Exp -> Exp - Fun :: Maybe Name -> [Var] -> Stm -> Exp - Call :: Arity -> Call -> Exp -> [Exp] -> Exp - Index :: Exp -> Exp -> Exp - Arr :: [Exp] -> Exp - AssignEx :: Exp -> Exp -> Exp - IfEx :: Exp -> Exp -> Exp -> Exp - Eval :: Exp -> Exp - Thunk :: Stm -> Exp + Var :: !Var -> Exp + Lit :: !Lit -> Exp + Not :: !Exp -> Exp + BinOp :: !BinOp -> Exp -> !Exp -> Exp + Fun :: !(Maybe Name) -> ![Var] -> !Stm -> Exp + Call :: !Arity -> !Call -> !Exp -> ![Exp] -> Exp + Index :: !Exp -> !Exp -> Exp + Arr :: ![Exp] -> Exp + AssignEx :: !Exp -> !Exp -> Exp + IfEx :: !Exp -> !Exp -> !Exp -> Exp + Eval :: !Exp -> Exp + Thunk :: !Stm -> Exp deriving (Eq, Show) -- | Statements. The only mildly interesting thing here are the Case and Jump -- constructors, which allow explicit sharing of continuations. data Stm where - Case :: Exp -> Stm -> [Alt] -> Shared Stm -> Stm - Forever :: Stm -> Stm - Assign :: LHS -> Exp -> Stm -> Stm - Return :: Exp -> Stm + Case :: !Exp -> !Stm -> ![Alt] -> !(Shared Stm) -> Stm + Forever :: !Stm -> Stm + Assign :: !LHS -> !Exp -> !Stm -> Stm + Return :: !Exp -> Stm Cont :: Stm - Jump :: Shared Stm -> Stm + Jump :: !(Shared Stm) -> Stm NullRet :: Stm - Tailcall :: Exp -> Stm - ThunkRet :: Exp -> Stm -- Return from a Thunk + Tailcall :: !Exp -> Stm + ThunkRet :: !Exp -> Stm -- Return from a Thunk deriving (Eq, Show) -- | Case alternatives - an expression to match and a branch. @@ -120,6 +124,17 @@ modDefs :: !(M.Map Name (AST 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 { @@ -141,8 +156,8 @@ -- | An AST with local jumps. data AST a = AST { - astCode :: a, - astJumps :: JumpTable + astCode :: !a, + astJumps :: !JumpTable } deriving (Show, Eq) instance Functor AST where diff --git a/src/Data/JSTarget/Traversal.hs b/src/Data/JSTarget/Traversal.hs --- a/src/Data/JSTarget/Traversal.hs +++ b/src/Data/JSTarget/Traversal.hs @@ -7,7 +7,7 @@ import Data.Map as M ((!), insert) -- | AST nodes we'd like to fold and map over. -data ASTNode = Exp Exp | Stm Stm | Label Lbl +data ASTNode = Exp !Exp | Stm !Stm | Label !Lbl newtype TravM a = T (JumpTable -> (JumpTable, a)) instance Monad TravM where diff --git a/src/Haste/Module.hs b/src/Haste/Module.hs --- a/src/Haste/Module.hs +++ b/src/Haste/Module.hs @@ -8,12 +8,12 @@ import Data.Binary -- | The file extension to use for modules. -jsmodExt :: String -jsmodExt = "jsmod" +jsmodExt :: Bool -> String +jsmodExt boot = if boot then "jsmod-boot" else "jsmod" -moduleFilePath :: FilePath -> String -> String -> FilePath -moduleFilePath basepath pkgid modname = - flip addExtension jsmodExt $ +moduleFilePath :: FilePath -> String -> String -> Bool -> FilePath +moduleFilePath basepath pkgid modname boot = + flip addExtension (jsmodExt boot) $ basepath pkgid (moduleNameSlashes $ mkModuleName modname) -- | Write a module to file, with the extension specified in `fileExt`. @@ -21,19 +21,28 @@ -- basepath/Foo/Bar.jsmod -- If any directory in the path where the module is to be written doesn't -- exist, it gets created. -writeModule :: FilePath -> Module -> IO () -writeModule basepath m@(Module pkgid modname _ _) = +writeModule :: FilePath -> Module -> Bool -> IO () +writeModule basepath m@(Module pkgid modname _ _) boot = fromRight "writeModule" . shell $ do mkdir True (takeDirectory path) liftIO $ B.writeFile path (encode m) where - path = moduleFilePath basepath pkgid modname + path = moduleFilePath basepath pkgid modname boot -- | Read a module from file. If the module is not found at the specified path, --- libpath/path is tried instead. Panics if the module is found on neither --- path. +-- libpath/path is tried instead. Returns Nothing is the module is not found +-- on either path. readModule :: FilePath -> String -> String -> IO (Maybe Module) readModule basepath pkgid modname = fromRight "readModule" . shell $ do + mm <- readMod basepath pkgid modname False + mmboot <- readMod basepath pkgid modname True + case (mm, mmboot) of + (Just m, Nothing) -> return $ Just m + (Just m, Just mboot) -> return . Just $ merge mboot m + _ -> return Nothing + +readMod :: FilePath -> String -> String -> Bool -> Shell (Maybe Module) +readMod basepath pkgid modname boot = do x <- isFile path let path' = if x then path else syspath isF <- isFile path' @@ -41,8 +50,8 @@ then Just . decode <$> liftIO (B.readFile path') else return Nothing where - path = moduleFilePath "." pkgid modname - syspath = moduleFilePath basepath pkgid modname + path = moduleFilePath "." pkgid modname boot + syspath = moduleFilePath basepath pkgid modname boot fromRight :: String -> IO (Either String b) -> IO b fromRight from m = do diff --git a/src/Haste/Monad.hs b/src/Haste/Monad.hs --- a/src/Haste/Monad.hs +++ b/src/Haste/Monad.hs @@ -12,19 +12,19 @@ deps :: !(S.Set Name), locals :: !(S.Set Name), continuation :: !(AST Stm -> AST Stm), - bindStack :: [Var], - modName :: String, - config :: cfg + bindStack :: ![Var], + modName :: !String, + config :: !cfg } -initialState :: GenState cfg -initialState = GenState { +initialState :: cfg -> GenState cfg +initialState cfg = GenState { deps = S.empty, locals = S.empty, continuation = id, bindStack = [], - modName = undefined, - config = undefined + modName = "", + config = cfg } newtype JSGen cfg a = @@ -65,7 +65,7 @@ -> JSGen cfg a -- ^ The code generation computation. -> (a, S.Set J.Name, S.Set J.Name, AST Stm -> AST Stm) genJS cfg myModName (JSGen gen) = - case runState gen initialState {modName = myModName, config = cfg} of + case runState gen (initialState cfg) {modName = myModName} of (a, GenState dependencies loc cont _ _ _) -> (a, dependencies, loc, cont) diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs --- a/src/Haste/Version.hs +++ b/src/Haste/Version.hs @@ -9,7 +9,7 @@ import Haste.Environment (hasteSysDir, ghcBinary) hasteVersion :: Version -hasteVersion = Version [0, 4, 2] [] +hasteVersion = Version [0, 4, 2, 1] [] ghcVersion :: String ghcVersion = unsafePerformIO $ do diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -233,22 +233,23 @@ -- | Compile a module into a .jsmod intermediate file. compile :: (GhcMonad m) => Config -> DynFlags -> ModSummary -> m () compile cfg dynflags modSummary = do - case ms_hsc_src modSummary of - HsBootFile -> liftIO $ logStr cfg $ "Skipping boot " ++ myName - _ -> do - (pgm, name) <- prepare dynflags modSummary + let boot = case ms_hsc_src modSummary of + HsBootFile -> True + _ -> False + (pgm, name) <- prepare dynflags modSummary #if __GLASGOW_HASKELL__ >= 706 - let pkgid = showPpr dynflags $ modulePackageId $ ms_mod modSummary - cfg' = cfg {showOutputable = showPpr dynflags} + let pkgid = showPpr dynflags $ modulePackageId $ ms_mod modSummary + cfg' = cfg {showOutputable = showPpr dynflags} #else - let pkgid = showPpr $ modulePackageId $ ms_mod modSummary - cfg' = cfg {showOutputable = showPpr} + let pkgid = showPpr $ modulePackageId $ ms_mod modSummary + cfg' = cfg {showOutputable = showPpr} #endif - theCode = generate cfg' pkgid name pgm - liftIO $ logStr cfg $ "Compiling " ++ myName ++ " into " ++ targetpath - liftIO $ writeModule targetpath theCode + theCode = generate cfg' pkgid name pgm + liftIO $ logStr cfg $ "Compiling " ++ myName boot ++ " into " ++ targetpath + liftIO $ writeModule targetpath theCode boot where - myName = moduleNameString $ moduleName $ ms_mod modSummary + myName False = moduleNameString $ moduleName $ ms_mod modSummary + myName True = myName False ++ " [boot]" targetpath = targetLibPath cfg -- | Fill in linkage info, such as whether to link at all and what the program