packages feed

haste-compiler 0.2 → 0.2.1

raw patch · 12 files changed

+127/−25 lines, 12 files

Files

haste-compiler.cabal view
@@ -1,5 +1,5 @@ Name:           haste-compiler-Version:        0.2+Version:        0.2.1 License:        BSD3 License-File:   LICENSE Synopsis:       Haskell To ECMAScript compiler@@ -29,6 +29,7 @@     md5.js     array.js     pointers.js+    debug.js  Executable haste-boot     Main-Is: haste-boot.hs
+ lib/debug.js view
@@ -0,0 +1,20 @@+/* debug.js+   Debugging utilities, tracing, etc.+ */++if(typeof print != 'undefined') {+    var __h_debug = print;+} else if(typeof console != 'undefined') {+    var __h_debug = function(x) {console.log(x)};+} else {+    var __h_debug = alert;+}++/* Trace something with arguments and a return value */+function __h_trace(msg, args, res) {+    var str = "TRACE:     " + msg + "\n"+            + "  ARGS:    " + args + "\n"+            + "  RETURNS: " + res;+    __h_debug(str);+    return res;+}
src/ArgSpecs.hs view
@@ -8,11 +8,11 @@ argSpecs :: [ArgSpec Config] argSpecs = [     ArgSpec { optName = "debug",-              updateCfg = \cfg _ -> cfg {ppOpts  = debugPPOpts},+              updateCfg = \cfg _ -> cfg {ppOpts = debugPPOpts},               info = "Output indented, fairly readable code, with all " ++                      "external names included in comments."},     ArgSpec { optName = "dont-link",-              updateCfg = \cfg _ -> cfg {performLink   = False},+              updateCfg = \cfg _ -> cfg {performLink = False},               info = "Don't perform linking."},     ArgSpec { optName = "libinstall",               updateCfg = \cfg _ -> cfg {targetLibPath = jsmodDir,@@ -68,6 +68,11 @@     ArgSpec { optName = "start=asap",               updateCfg = \cfg _ -> cfg {appStart = startASAP},               info = "Start program immediately instead of on document load."},+    ArgSpec { optName = "trace-primops",+              updateCfg = \cfg _ -> cfg {tracePrimops = True,+                                         rtsLibs = debugLib : rtsLibs cfg},+              info = "Turn on run-time tracing of primops. Also turned on by "+                   ++ "-debug."},     ArgSpec { optName = "verbose",               updateCfg = \cfg _ -> cfg {verbose = True},               info = "Display even the most obnoxious warnings."},
src/Data/JSTarget/Op.hs view
@@ -66,3 +66,14 @@ 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/Print.hs view
@@ -56,8 +56,10 @@       _ -> if expPrec (Not ex) > expPrec ex              then "!(" .+. pp ex .+. ")"              else "!" .+. pp ex-  pp (BinOp op a b) =-    opParens op a b+  pp bop@(BinOp _ _ _) =+    case norm bop of+      BinOp op a b -> opParens op a b+      ex           -> pp ex   pp (Fun mname args body) = do       "function" .+. lambdaname .+. "(" .+. ppList sep args .+. "){" .+. newl       indent $ pp body@@ -196,9 +198,20 @@ opParens op a b = do   let bparens = case b of                   Lit (LNum n) | n < 0 -> \x -> "(".+. pp x .+. ")"-                  _                          -> parens-  parens a >> put (string7 $ show op) >> bparens b+                  _                          -> parensR+  parensL a .+. put (string7 $ show op) .+. bparens b   where-    parens x = if expPrec x < opPrec op-               then "(" .+. pp x .+. ")"-               else pp x+    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.+norm :: Exp -> Exp+norm (BinOp op a (BinOp op' b c)) | op == op' && opIsAssoc op =+  norm (BinOp op (BinOp op a b) c)+norm e =+  e
src/Haste/CodeGen.hs view
@@ -79,10 +79,32 @@     myModName = moduleNameString modname     depsAndCode (_, ds, locs, stm) = (ds S.\\ locs, stm nullRet) +-- | Check for builtins that should generate inlined code. At this point only+--   w2i and i2w.+genInlinedBuiltin :: Var.Var -> [StgArg] -> JSGen Config (Maybe (AST Exp))+genInlinedBuiltin f [x] = do+    x' <- genArg x+    return $ case (modname, varname) of+      (Just "GHC.HasteWordInt", "w2i") ->+        Just $ binOp BitAnd x' (litN 0xffffffff)+      (Just "GHC.HasteWordInt", "i2w") ->+        Just $ binOp ShrL x' (litN 0)+      _ ->+        Nothing+  where+    modname = moduleNameString . moduleName <$> nameModule_maybe (Var.varName f)+    varname = occNameString $ nameOccName $ Var.varName f+genInlinedBuiltin _ _ =+  return Nothing++ -- | Generate code for an STG expression. genEx :: StgExpr -> JSGen Config (AST Exp) genEx (StgApp f xs) = do-  genApp f xs+  mex <- genInlinedBuiltin f xs+  case mex of+    Just ex -> return ex+    _       -> genApp f xs genEx (StgLit l) = do   genLit l genEx (StgConApp con args) = do@@ -103,11 +125,13 @@   cfg <- getCfg   let theOp = case op of         StgPrimOp op' ->-          genOp cfg op' args'+          maybeTrace cfg (showOutputable op') args' <$> genOp cfg op' args'         StgPrimCallOp (PrimCall f _) ->-          Right $ callForeign (unpackFS f) args'+          Right $ maybeTrace cfg fs args' $ callForeign fs args'+          where fs = unpackFS f         StgFCallOp (CCall (CCallSpec (StaticTarget f _ _) _ _)) _t ->-          Right $ callForeign (unpackFS f) args'+          Right $ maybeTrace cfg fs args' $ callForeign fs args'+          where fs = unpackFS f         _ ->           error $ "Tried to generate unsupported dynamic foreign call!"   case theOp of@@ -128,6 +152,13 @@ genEx (StgLam _ _) = do   error "StgLam caught during code generation - that's impossible!" +-- | Trace the given expression, if tracing is on.+maybeTrace :: Config -> String -> [AST Exp] -> AST Exp -> AST Exp+maybeTrace cfg msg args ex =+  if tracePrimops cfg+    then callForeign "__h_trace" [lit msg, array args, ex]+    else ex+ genBindRec :: StgBinding -> JSGen Config () genBindRec bs@(StgRec _) = do     mapM_ (genBind False (Just len) . snd) bs'@@ -289,7 +320,7 @@ genVar v | hasRepresentation v = do   case toBuiltin v of     Just v' -> return v'-    _         -> do+    _       -> do       mymod <- getModName       v' <- return $ toJSVar mymod v Nothing       dependOn v'@@ -401,14 +432,14 @@     MachStr s           -> return . lit $ hexifyString s     MachInt n       | n > 2147483647 ||-        n < -2147483648 -> do warn Normal (constFail "Int" n)+        n < -2147483648 -> do warn Verbose (constFail "Int" n)                               return $ truncInt n       | otherwise       -> return . litN $ fromIntegral n     MachFloat f         -> return . litN $ fromRational f     MachDouble d        -> return . litN $ fromRational d     MachChar c          -> return . litN $ fromIntegral $ ord c     MachWord w-      | w > 0xffffffff  -> do warn Normal (constFail "Word" w)+      | w > 0xffffffff  -> do warn Verbose (constFail "Word" w)                               return $ truncWord w       | otherwise       -> return . litN $ fromIntegral w     MachWord64 w        -> return . litN $ fromIntegral w
src/Haste/Config.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Haste.Config (   Config (..), AppStart, defConfig, stdJSLibs, startASAP,-  startOnLoadComplete, fastMultiply, safeMultiply) where+  startOnLoadComplete, fastMultiply, safeMultiply, debugLib) where import Data.JSTarget import System.IO.Unsafe (unsafePerformIO) import System.FilePath (replaceExtension)@@ -19,6 +19,9 @@     "array.js", "pointers.js"   ] +debugLib :: FilePath+debugLib = unsafePerformIO $ getDataFileName "debug.js"+ -- | Execute the program as soon as it's loaded into memory. --   Evaluate the result of applying main, as we might get a thunk back if --   we're doing TCE. This is so cheap, small and non-intrusive we might@@ -73,6 +76,8 @@     -- | Allow the possibility that some tail recursion may not be optimized     --   in order to gain slightly smaller code?     sloppyTCE :: Bool,+    -- | Turn on run-time tracing of primops?+    tracePrimops :: Bool,     -- | Run the entire thing through Google Closure when done?     useGoogleClosure :: Maybe FilePath,     -- | Any external Javascript to link into the JS bundle.@@ -96,6 +101,7 @@     verbose          = False,     wholeProgramOpts = False,     sloppyTCE        = False,+    tracePrimops     = False,     useGoogleClosure = Nothing,     jsExternals      = [],     dynFlags         = tracingDynFlags
src/Haste/Monad.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-} module Haste.Monad (     JSGen, genJS, dependOn, getModName, addLocal, getCfg, continue, isolate,-    pushBind, popBind, getCurrentBinding+    pushBind, popBind, getCurrentBinding, whenCfg   ) where import Control.Monad.State import Data.JSTarget as J hiding (modName)@@ -106,3 +106,8 @@  getCfg :: JSGen cfg cfg getCfg = JSGen $ fmap config get++whenCfg :: (cfg -> Bool) -> JSGen cfg () -> JSGen cfg ()+whenCfg p act = do+  cfg <- getCfg+  when (p cfg) act
src/Haste/PrimOps.hs view
@@ -211,6 +211,13 @@     ReadMutVarOp -> callF "rMV"     WriteMutVarOp -> callF "wMV"     +    -- TVars - since there's no parallelism and no preemption, TVars behave+    -- just like normal IORefs.+    NewTVarOp   -> callF "nMV"+    ReadTVarOp  -> callF "rMV"+    WriteTVarOp -> callF "wMV"+    SameTVarOp  -> bOp Eq+     -- Pointer ops     WriteOffAddrOp_Char    -> writeOffAddr xs "i8"  1     WriteOffAddrOp_Int     -> writeOffAddr xs "i32" 4@@ -266,6 +273,11 @@     MakeStableNameOp  -> callF "makeStableName"     EqStableNameOp    -> callF "eqStableName"     StableNameToIntOp -> Right $ head xs++    -- Stable pointers - all pointers are stable in JS!+    MakeStablePtrOp   -> Right $ head xs+    EqStablePtrOp     -> Right $ head xs+    DeRefStablePtrOp  -> Right $ head xs      -- Exception masking     -- There's only one thread anyway, so async exceptions can't happen.
src/Haste/Version.hs view
@@ -10,7 +10,7 @@ import Haste.Environment (hasteDir)  hasteVersion :: Version-hasteVersion = Version [0, 2] []+hasteVersion = Version [0, 2, 1] []  ghcVersion :: String ghcVersion = cProjectVersion
src/Main.hs view
@@ -106,9 +106,8 @@ -- | The main compiler driver. compiler :: [String] -> IO () compiler cmdargs = do-  let cmdargs' | "--opt-all" `elem` cmdargs = "-O2" : cmdargs-               | "--opt-all-unsafe" `elem` cmdargs = "-O2" : cmdargs-               | otherwise                  = cmdargs+  let cmdargs' | "-debug" `elem` cmdargs = "--trace-primops":cmdargs+               | otherwise               = cmdargs       argRes = handleArgs defConfig argSpecs cmdargs'       usedGhcMode = if "-c" `elem` cmdargs then OneShot else CompManager
src/haste-boot.hs view
@@ -127,9 +127,8 @@           run_ "haste-install-his" ["ghc-prim-0.3.0.0", "dist" </> "build"] ""           run_ "haste-pkg" ["update", "packageconfig"] ""         -        -- Install integer-gmp twice, since it may misbehave the first time.+        -- Install integer-gmp; double install shouldn't be needed anymore.         inDirectory "integer-gmp" $ do-          hasteInst ["install", ghcOpts]           hasteInst ["install", ghcOpts]                  -- Install base