diff options
Diffstat (limited to 'compiler/GHC/StgToJS')
25 files changed, 152 insertions, 226 deletions
diff --git a/compiler/GHC/StgToJS/Apply.hs b/compiler/GHC/StgToJS/Apply.hs index 6d40f8a7ac..bef12354e6 100644 --- a/compiler/GHC/StgToJS/Apply.hs +++ b/compiler/GHC/StgToJS/Apply.hs @@ -27,7 +27,7 @@ where import GHC.Prelude hiding ((.|.)) -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Arg diff --git a/compiler/GHC/StgToJS/Arg.hs b/compiler/GHC/StgToJS/Arg.hs index 854bf7cc17..1f406635ec 100644 --- a/compiler/GHC/StgToJS/Arg.hs +++ b/compiler/GHC/StgToJS/Arg.hs @@ -30,7 +30,7 @@ where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.DataCon diff --git a/compiler/GHC/StgToJS/Closure.hs b/compiler/GHC/StgToJS/Closure.hs index 4604eccdb7..fdcaa05c5e 100644 --- a/compiler/GHC/StgToJS/Closure.hs +++ b/compiler/GHC/StgToJS/Closure.hs @@ -31,7 +31,7 @@ import GHC.StgToJS.CoreUtils import GHC.StgToJS.Regs (stack,sp) import GHC.JS.Make -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.Types.Unique.Map diff --git a/compiler/GHC/StgToJS/CodeGen.hs b/compiler/GHC/StgToJS/CodeGen.hs index 7703398aea..55be51df9d 100644 --- a/compiler/GHC/StgToJS/CodeGen.hs +++ b/compiler/GHC/StgToJS/CodeGen.hs @@ -13,7 +13,7 @@ import GHC.Prelude import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js)) import GHC.JS.Ppr -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform @@ -134,6 +134,7 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . + satJStat . jsSaturate (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] @@ -207,7 +208,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = jsSaturate (Just $ modulePrefix m n) body + let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -245,6 +246,7 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . + satJStat . jsSaturate (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps diff --git a/compiler/GHC/StgToJS/CoreUtils.hs b/compiler/GHC/StgToJS/CoreUtils.hs index 0fdf7a5ed8..751661b11b 100644 --- a/compiler/GHC/StgToJS/CoreUtils.hs +++ b/compiler/GHC/StgToJS/CoreUtils.hs @@ -6,7 +6,8 @@ module GHC.StgToJS.CoreUtils where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax +import GHC.JS.Transform import GHC.StgToJS.Types @@ -246,17 +247,17 @@ primRepSize p = varSlotCount (primRepVt p) -- | Associate the given values to each RrimRep in the given order, taking into -- account the number of slots per PrimRep -assocPrimReps :: Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])] +assocPrimReps :: [PrimRep] -> [JExpr] -> [(PrimRep, [JExpr])] assocPrimReps [] _ = [] assocPrimReps (r:rs) vs = case (primRepSize r,vs) of (NoSlot, xs) -> (r,[]) : assocPrimReps rs xs (OneSlot, x:xs) -> (r,[x]) : assocPrimReps rs xs (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs - err -> pprPanic "assocPrimReps" (ppr err) + err -> pprPanic "assocPrimReps" (ppr $ fmap (map satJExpr) $ err) -- | Associate the given values to the Id's PrimReps, taking into account the -- number of slots per PrimRep -assocIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])] +assocIdPrimReps :: Id -> [JExpr] -> [(PrimRep, [JExpr])] assocIdPrimReps i = assocPrimReps (idPrimReps i) -- | Associate the given JExpr to the Id's PrimReps, taking into account the diff --git a/compiler/GHC/StgToJS/DataCon.hs b/compiler/GHC/StgToJS/DataCon.hs index cf82c2f6ac..675fd6d583 100644 --- a/compiler/GHC/StgToJS/DataCon.hs +++ b/compiler/GHC/StgToJS/DataCon.hs @@ -27,7 +27,8 @@ where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax +import GHC.JS.Transform import GHC.JS.Make import GHC.StgToJS.Closure @@ -58,7 +59,10 @@ genCon ctx con args = allocCon ctxi con currentCCS args | xs <- concatMap typex_expr (ctxTarget ctx) - = pprPanic "genCon: unhandled DataCon" (ppr (con, args, xs)) + = pprPanic "genCon: unhandled DataCon" (ppr (con + , fmap satJExpr args + , fmap satJExpr xs + )) -- | Allocate a data constructor. Allocate in this context means bind the data -- constructor to 'to' @@ -86,7 +90,7 @@ allocUnboxedCon con = \case | isBoolDataCon con && dataConTag con == 2 -> true_ [x] | isUnboxableCon con -> x - xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con,xs)) + xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, fmap satJExpr xs)) -- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout. allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig diff --git a/compiler/GHC/StgToJS/Deps.hs b/compiler/GHC/StgToJS/Deps.hs index bd7d2c75bd..e76d3afee1 100644 --- a/compiler/GHC/StgToJS/Deps.hs +++ b/compiler/GHC/StgToJS/Deps.hs @@ -26,7 +26,7 @@ import GHC.StgToJS.Object as Object import GHC.StgToJS.Types import GHC.StgToJS.Ids -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.Types.Id import GHC.Types.Unique diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs index d42d93afe8..9f5a1f6d0a 100644 --- a/compiler/GHC/StgToJS/Expr.hs +++ b/compiler/GHC/StgToJS/Expr.hs @@ -30,7 +30,8 @@ where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax +import GHC.JS.Transform import GHC.JS.Make import GHC.StgToJS.Apply @@ -910,7 +911,7 @@ caseCond = \case DataAlt da -> return $ Just (toJExpr $ dataConTag da) LitAlt l -> genLit l >>= \case [e] -> pure (Just e) - es -> pprPanic "caseCond: expected single-variable literal" (ppr es) + es -> pprPanic "caseCond: expected single-variable literal" (ppr $ fmap satJExpr es) -- fixme use single tmp var for all branches -- | Load parameters from constructor diff --git a/compiler/GHC/StgToJS/FFI.hs b/compiler/GHC/StgToJS/FFI.hs index 0c1a713f70..effaa1f122 100644 --- a/compiler/GHC/StgToJS/FFI.hs +++ b/compiler/GHC/StgToJS/FFI.hs @@ -11,7 +11,7 @@ where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform @@ -27,7 +27,6 @@ import GHC.StgToJS.Ids import GHC.Types.RepType import GHC.Types.ForeignCall import GHC.Types.Unique.Map -import GHC.Types.Unique.FM import GHC.Stg.Syntax @@ -37,17 +36,12 @@ import GHC.Builtin.Types.Prim import GHC.Core.Type hiding (typeSize) import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr, vcat, text) +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) import GHC.Data.FastString import Data.Char import Data.Monoid -import Data.Maybe import qualified Data.List as L -import Control.Monad -import Control.Applicative -import qualified Text.ParserCombinators.ReadP as P genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult) genPrimCall ctx (PrimCall lbl _) args t = do @@ -136,32 +130,8 @@ parseFFIPattern' :: Maybe JExpr -- ^ Nothing for sync, Just callback for async -> G JStat parseFFIPattern' callback javascriptCc pat t ret args | not javascriptCc = mkApply pat - | otherwise = - if True - then mkApply pat - else do - u <- freshUnique - case parseFfiJME pat u of - Right (ValExpr (JVar (TxtI _ident))) -> mkApply pat - Right expr | not async && length tgt < 2 -> do - (statPre, ap) <- argPlaceholders javascriptCc args - let rp = resultPlaceholders async t ret - env = addListToUFM emptyUFM (rp ++ ap) - if length tgt == 1 - then return $ statPre <> (mapStatIdent (replaceIdent env) (var "$r" |= expr)) - else return $ statPre <> (mapStatIdent (replaceIdent env) (toStat expr)) - Right _ -> p $ "invalid expression FFI pattern. Expression FFI patterns can only be used for synchronous FFI " ++ - " imports with result size 0 or 1.\n" ++ pat - Left _ -> case parseFfiJM pat u of - Left err -> p (show err) - Right stat -> do - let rp = resultPlaceholders async t ret - let cp = callbackPlaceholders callback - (statPre, ap) <- argPlaceholders javascriptCc args - let env = addListToUFM emptyUFM (rp ++ ap ++ cp) - return $ statPre <> (mapStatIdent (replaceIdent env) stat) -- fixme trace? + | otherwise = mkApply pat where - async = isJust callback tgt = take (typeSize t) ret -- automatic apply, build call and result copy mkApply f @@ -184,33 +154,11 @@ parseFFIPattern' callback javascriptCc pat t ret args return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as) where f' = toJExpr (TxtI $ mkFastString f) copyResult rs = mconcat $ zipWith (\t r -> toJExpr r |= toJExpr t) (enumFrom Ret1) rs - p e = error ("Parse error in FFI pattern: " ++ pat ++ "\n" ++ e) - - replaceIdent :: UniqFM Ident JExpr -> Ident -> JExpr - replaceIdent env i - | isFFIPlaceholder i = fromMaybe err (lookupUFM env i) - | otherwise = ValExpr (JVar i) - where - (TxtI i') = i - err = pprPanic "parseFFIPattern': invalid placeholder, check function type" - (vcat [text pat, ppr i', ppr args, ppr t]) + traceCall cs as | csTraceForeign cs = ApplStat (var "h$traceForeign") [toJExpr pat, toJExpr as] | otherwise = mempty --- ident is $N, $N_R, $rN, $rN_R or $r or $c -isFFIPlaceholder :: Ident -> Bool -isFFIPlaceholder (TxtI x) = not (null (P.readP_to_S parser (unpackFS x))) - where - digit = P.satisfy (`elem` ("0123456789" :: String)) - parser = void (P.string "$r" >> P.eof) <|> - void (P.string "$c" >> P.eof) <|> do - _ <- P.char '$' - P.optional (P.char 'r') - _ <- P.many1 digit - P.optional (P.char '_' >> P.many1 digit) - P.eof - -- generate arg to be passed to FFI call, with marshalling JStat to be run -- before the call genFFIArg :: Bool -> StgArg -> G (JStat, [JExpr]) @@ -228,57 +176,6 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty --- $1, $2, $3 for single, $1_1, $1_2 etc for dual --- void args not counted -argPlaceholders :: Bool -> [StgArg] -> G (JStat, [(Ident,JExpr)]) -argPlaceholders isJavaScriptCc args = do - (stats, idents0) <- unzip <$> mapM (genFFIArg isJavaScriptCc) args - let idents = filter (not . null) idents0 - return $ (mconcat stats, concat - (zipWith (\is n -> mkPlaceholder True ("$"++show n) is) idents [(1::Int)..])) - -mkPlaceholder :: Bool -> String -> [JExpr] -> [(Ident, JExpr)] -mkPlaceholder undersc prefix aids = - case aids of - [] -> [] - [x] -> [(TxtI . mkFastString $ prefix, x)] - xs@(x:_) -> (TxtI . mkFastString $ prefix, x) : - zipWith (\x m -> (TxtI . mkFastString $ prefix ++ u ++ show m,x)) xs [(1::Int)..] - where u = if undersc then "_" else "" - --- $r for single, $r1,$r2 for dual --- $r1, $r2, etc for ubx tup, void args not counted -resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident,JExpr)] -- ident, replacement -resultPlaceholders True _ _ = [] -- async has no direct resuls, use callback -resultPlaceholders False t rs = - case typeVt (unwrapType t) of - [t'] -> mkUnary (varSize t') - uts -> - let sizes = filter (>0) (map varSize uts) - f _ 0 = [] - f n 1 = [["$r" ++ show n]] - f n k = ["$r" ++ sn, "$r" ++ sn ++ "_1"] : map (\x -> ["$r" ++ sn ++ "_" ++ show x]) [2..k] - where sn = show n - phs = zipWith (\size n -> f n size) sizes [(1::Int)..] - in case sizes of - [n] -> mkUnary n - _ -> concat $ zipWith (\phs' r -> map (\i -> (TxtI (mkFastString i), r)) phs') (concat phs) rs - where - mkUnary 0 = [] - mkUnary 1 = [(TxtI "$r",head rs)] -- single - mkUnary n = [(TxtI "$r",head rs),(TxtI "$r1", head rs)] ++ - zipWith (\n r -> (TxtI . mkFastString $ "$r" ++ show n, toJExpr r)) [2..n] (tail rs) - -callbackPlaceholders :: Maybe JExpr -> [(Ident,JExpr)] -callbackPlaceholders Nothing = [] -callbackPlaceholders (Just e) = [((TxtI "$c"), e)] - -parseFfiJME :: String -> Int -> Either String JExpr -parseFfiJME _xs _u = Left "parseFfiJME not yet implemented" - -parseFfiJM :: String -> Int -> Either String JStat -parseFfiJM _xs _u = Left "parseFfiJM not yet implemented" - saturateFFI :: JMacro a => Int -> a -> a saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) diff --git a/compiler/GHC/StgToJS/Heap.hs b/compiler/GHC/StgToJS/Heap.hs index fe2955812d..43c1228ab1 100644 --- a/compiler/GHC/StgToJS/Heap.hs +++ b/compiler/GHC/StgToJS/Heap.hs @@ -38,7 +38,7 @@ where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Types import GHC.Data.FastString diff --git a/compiler/GHC/StgToJS/Ids.hs b/compiler/GHC/StgToJS/Ids.hs index 9817b326a3..3412f16e4f 100644 --- a/compiler/GHC/StgToJS/Ids.hs +++ b/compiler/GHC/StgToJS/Ids.hs @@ -43,7 +43,7 @@ import GHC.StgToJS.Monad import GHC.StgToJS.CoreUtils import GHC.StgToJS.Symbols -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.Core.DataCon diff --git a/compiler/GHC/StgToJS/Linker/Linker.hs b/compiler/GHC/StgToJS/Linker/Linker.hs index 0739c73204..07a501cc2b 100644 --- a/compiler/GHC/StgToJS/Linker/Linker.hs +++ b/compiler/GHC/StgToJS/Linker/Linker.hs @@ -30,7 +30,8 @@ import Prelude import GHC.Platform.Host (hostPlatformArchOS) import GHC.JS.Make -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax +import GHC.JS.Transform import GHC.Driver.Session (DynFlags(..)) import Language.Haskell.Syntax.Module.Name @@ -325,12 +326,12 @@ renderLinker h mods jsFiles = do -- modules themselves mod_sizes <- forM compacted_mods $ \m -> do - !mod_size <- fromIntegral <$> putJS (cmc_js_code m) + !mod_size <- fromIntegral <$> putJS (satJStat $! cmc_js_code m) let !mod_mod = cmc_module m pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS meta + !meta_length <- fromIntegral <$> putJS (satJStat meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods @@ -564,7 +565,7 @@ extractDeps ar_state units deps loc = mod = depsModule deps newline = BC.pack "\n" mk_exports = mconcat . intersperse newline . filter (not . BS.null) . map oiRaw - mk_js_code = mconcat . map oiStat + mk_js_code = mconcat . map (unsatJStat . oiStat) collectCode l = ModuleCode { mc_module = mod , mc_js_code = mk_js_code l diff --git a/compiler/GHC/StgToJS/Literal.hs b/compiler/GHC/StgToJS/Literal.hs index 13549cd324..7ba0295eed 100644 --- a/compiler/GHC/StgToJS/Literal.hs +++ b/compiler/GHC/StgToJS/Literal.hs @@ -9,7 +9,7 @@ where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Types diff --git a/compiler/GHC/StgToJS/Monad.hs b/compiler/GHC/StgToJS/Monad.hs index b8deb36a63..2c4575dd9e 100644 --- a/compiler/GHC/StgToJS/Monad.hs +++ b/compiler/GHC/StgToJS/Monad.hs @@ -24,7 +24,7 @@ where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Transform import GHC.StgToJS.Types diff --git a/compiler/GHC/StgToJS/Object.hs b/compiler/GHC/StgToJS/Object.hs index f75d27e20b..ec4abcaf50 100644 --- a/compiler/GHC/StgToJS/Object.hs +++ b/compiler/GHC/StgToJS/Object.hs @@ -77,7 +77,8 @@ import System.IO import GHC.Settings.Constants (hiVersion) -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Types import GHC.Unit.Module @@ -402,84 +403,101 @@ instance Binary ExpFun where put_ bh (ExpFun isIO args res) = put_ bh isIO >> put_ bh args >> put_ bh res get bh = ExpFun <$> get bh <*> get bh <*> get bh -instance Binary JStat where - put_ bh (DeclStat i e) = putByte bh 1 >> put_ bh i >> put_ bh e - put_ bh (ReturnStat e) = putByte bh 2 >> put_ bh e - put_ bh (IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 - put_ bh (WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s - put_ bh (ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s - put_ bh (SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s - put_ bh (TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 - put_ bh (BlockStat xs) = putByte bh 8 >> put_ bh xs - put_ bh (ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es - put_ bh (UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e - put_ bh (AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2 - put_ _ (UnsatBlock {}) = error "put_ bh JStat: UnsatBlock" - put_ bh (LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s - put_ bh (BreakStat ml) = putByte bh 13 >> put_ bh ml - put_ bh (ContinueStat ml) = putByte bh 14 >> put_ bh ml +instance Binary Sat.JStat where + put_ bh (Sat.DeclStat i e) = putByte bh 1 >> put_ bh i >> put_ bh e + put_ bh (Sat.ReturnStat e) = putByte bh 2 >> put_ bh e + put_ bh (Sat.IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 + put_ bh (Sat.WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s + put_ bh (Sat.ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s + put_ bh (Sat.SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s + put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 + put_ bh (Sat.BlockStat xs) = putByte bh 8 >> put_ bh xs + put_ bh (Sat.ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es + put_ bh (Sat.UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e + put_ bh (Sat.AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2 + put_ bh (Sat.LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s + put_ bh (Sat.BreakStat ml) = putByte bh 13 >> put_ bh ml + put_ bh (Sat.ContinueStat ml) = putByte bh 14 >> put_ bh ml get bh = getByte bh >>= \case - 1 -> DeclStat <$> get bh <*> get bh - 2 -> ReturnStat <$> get bh - 3 -> IfStat <$> get bh <*> get bh <*> get bh - 4 -> WhileStat <$> get bh <*> get bh <*> get bh - 5 -> ForInStat <$> get bh <*> get bh <*> get bh <*> get bh - 6 -> SwitchStat <$> get bh <*> get bh <*> get bh - 7 -> TryStat <$> get bh <*> get bh <*> get bh <*> get bh - 8 -> BlockStat <$> get bh - 9 -> ApplStat <$> get bh <*> get bh - 10 -> UOpStat <$> get bh <*> get bh - 11 -> AssignStat <$> get bh <*> get bh - 12 -> LabelStat <$> get bh <*> get bh - 13 -> BreakStat <$> get bh - 14 -> ContinueStat <$> get bh + 1 -> Sat.DeclStat <$> get bh <*> get bh + 2 -> Sat.ReturnStat <$> get bh + 3 -> Sat.IfStat <$> get bh <*> get bh <*> get bh + 4 -> Sat.WhileStat <$> get bh <*> get bh <*> get bh + 5 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh + 6 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh + 7 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh + 8 -> Sat.BlockStat <$> get bh + 9 -> Sat.ApplStat <$> get bh <*> get bh + 10 -> Sat.UOpStat <$> get bh <*> get bh + 11 -> Sat.AssignStat <$> get bh <*> get bh + 12 -> Sat.LabelStat <$> get bh <*> get bh + 13 -> Sat.BreakStat <$> get bh + 14 -> Sat.ContinueStat <$> get bh n -> error ("Binary get bh JStat: invalid tag: " ++ show n) -instance Binary JExpr where - put_ bh (ValExpr v) = putByte bh 1 >> put_ bh v - put_ bh (SelExpr e i) = putByte bh 2 >> put_ bh e >> put_ bh i - put_ bh (IdxExpr e1 e2) = putByte bh 3 >> put_ bh e1 >> put_ bh e2 - put_ bh (InfixExpr o e1 e2) = putByte bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2 - put_ bh (UOpExpr o e) = putByte bh 5 >> put_ bh o >> put_ bh e - put_ bh (IfExpr e1 e2 e3) = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3 - put_ bh (ApplExpr e es) = putByte bh 7 >> put_ bh e >> put_ bh es - put_ _ (UnsatExpr {}) = error "put_ bh JExpr: UnsatExpr" + + +instance Binary Sat.JExpr where + put_ bh (Sat.ValExpr v) = putByte bh 1 >> put_ bh v + put_ bh (Sat.SelExpr e i) = putByte bh 2 >> put_ bh e >> put_ bh i + put_ bh (Sat.IdxExpr e1 e2) = putByte bh 3 >> put_ bh e1 >> put_ bh e2 + put_ bh (Sat.InfixExpr o e1 e2) = putByte bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2 + put_ bh (Sat.UOpExpr o e) = putByte bh 5 >> put_ bh o >> put_ bh e + put_ bh (Sat.IfExpr e1 e2 e3) = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3 + put_ bh (Sat.ApplExpr e es) = putByte bh 7 >> put_ bh e >> put_ bh es get bh = getByte bh >>= \case - 1 -> ValExpr <$> get bh - 2 -> SelExpr <$> get bh <*> get bh - 3 -> IdxExpr <$> get bh <*> get bh - 4 -> InfixExpr <$> get bh <*> get bh <*> get bh - 5 -> UOpExpr <$> get bh <*> get bh - 6 -> IfExpr <$> get bh <*> get bh <*> get bh - 7 -> ApplExpr <$> get bh <*> get bh - n -> error ("Binary get bh JExpr: invalid tag: " ++ show n) - -instance Binary JVal where - put_ bh (JVar i) = putByte bh 1 >> put_ bh i - put_ bh (JList es) = putByte bh 2 >> put_ bh es - put_ bh (JDouble d) = putByte bh 3 >> put_ bh d - put_ bh (JInt i) = putByte bh 4 >> put_ bh i - put_ bh (JStr xs) = putByte bh 5 >> put_ bh xs - put_ bh (JRegEx xs) = putByte bh 6 >> put_ bh xs - put_ bh (JHash m) = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m) - put_ bh (JFunc is s) = putByte bh 8 >> put_ bh is >> put_ bh s - put_ _ (UnsatVal {}) = error "put_ bh JVal: UnsatVal" + 1 -> Sat.ValExpr <$> get bh + 2 -> Sat.SelExpr <$> get bh <*> get bh + 3 -> Sat.IdxExpr <$> get bh <*> get bh + 4 -> Sat.InfixExpr <$> get bh <*> get bh <*> get bh + 5 -> Sat.UOpExpr <$> get bh <*> get bh + 6 -> Sat.IfExpr <$> get bh <*> get bh <*> get bh + 7 -> Sat.ApplExpr <$> get bh <*> get bh + n -> error ("Binary get bh UnsatExpr: invalid tag: " ++ show n) + + +instance Binary Sat.JVal where + put_ bh (Sat.JVar i) = putByte bh 1 >> put_ bh i + put_ bh (Sat.JList es) = putByte bh 2 >> put_ bh es + put_ bh (Sat.JDouble d) = putByte bh 3 >> put_ bh d + put_ bh (Sat.JInt i) = putByte bh 4 >> put_ bh i + put_ bh (Sat.JStr xs) = putByte bh 5 >> put_ bh xs + put_ bh (Sat.JRegEx xs) = putByte bh 6 >> put_ bh xs + put_ bh (Sat.JHash m) = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m) + put_ bh (Sat.JFunc is s) = putByte bh 8 >> put_ bh is >> put_ bh s get bh = getByte bh >>= \case - 1 -> JVar <$> get bh - 2 -> JList <$> get bh - 3 -> JDouble <$> get bh - 4 -> JInt <$> get bh - 5 -> JStr <$> get bh - 6 -> JRegEx <$> get bh - 7 -> JHash . listToUniqMap <$> get bh - 8 -> JFunc <$> get bh <*> get bh - n -> error ("Binary get bh JVal: invalid tag: " ++ show n) + 1 -> Sat.JVar <$> get bh + 2 -> Sat.JList <$> get bh + 3 -> Sat.JDouble <$> get bh + 4 -> Sat.JInt <$> get bh + 5 -> Sat.JStr <$> get bh + 6 -> Sat.JRegEx <$> get bh + 7 -> Sat.JHash . listToUniqMap <$> get bh + 8 -> Sat.JFunc <$> get bh <*> get bh + n -> error ("Binary get bh Sat.JVal: invalid tag: " ++ show n) instance Binary Ident where put_ bh (TxtI xs) = put_ bh xs get bh = TxtI <$> get bh -- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this +instance Binary Sat.SaneDouble where + put_ bh (Sat.SaneDouble d) + | isNaN d = putByte bh 1 + | isInfinite d && d > 0 = putByte bh 2 + | isInfinite d && d < 0 = putByte bh 3 + | isNegativeZero d = putByte bh 4 + | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d) + get bh = getByte bh >>= \case + 1 -> pure $ Sat.SaneDouble (0 / 0) + 2 -> pure $ Sat.SaneDouble (1 / 0) + 3 -> pure $ Sat.SaneDouble ((-1) / 0) + 4 -> pure $ Sat.SaneDouble (-0) + 5 -> Sat.SaneDouble . castWord64ToDouble <$> get bh + n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n) + +-- FIXME: remove after Unsat replaces JStat +-- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this instance Binary SaneDouble where put_ bh (SaneDouble d) | isNaN d = putByte bh 1 @@ -516,11 +534,11 @@ instance Binary CIRegs where 2 -> CIRegs <$> get bh <*> get bh n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n) -instance Binary JOp where +instance Binary Sat.Op where put_ bh = putEnum bh get bh = getEnum bh -instance Binary JUOp where +instance Binary Sat.UOp where put_ bh = putEnum bh get bh = getEnum bh diff --git a/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs index a29c08db93..5c81744f2a 100644 --- a/compiler/GHC/StgToJS/Prim.hs +++ b/compiler/GHC/StgToJS/Prim.hs @@ -13,7 +13,7 @@ where import GHC.Prelude -import GHC.JS.Syntax hiding (JUOp (..)) +import GHC.JS.Unsat.Syntax hiding (JUOp (..)) import GHC.JS.Make import GHC.StgToJS.Heap diff --git a/compiler/GHC/StgToJS/Printer.hs b/compiler/GHC/StgToJS/Printer.hs index f2e162d40f..f6d5c5cec9 100644 --- a/compiler/GHC/StgToJS/Printer.hs +++ b/compiler/GHC/StgToJS/Printer.hs @@ -94,7 +94,7 @@ hexDoc v = text $ go v -- attempt to resugar some of the common constructs ghcjsRenderJsS :: RenderJs -> JStat -> Doc ghcjsRenderJsS r (BlockStat xs) = prettyBlock r (flattenBlocks xs) -ghcjsRenderJsS r s = renderJsS defaultRenderJs r s +ghcjsRenderJsS r s = renderJsS defaultRenderJs r s -- don't quote keys in our object literals, so closure compiler works ghcjsRenderJsV :: RenderJs -> JVal -> Doc diff --git a/compiler/GHC/StgToJS/Profiling.hs b/compiler/GHC/StgToJS/Profiling.hs index cd27604082..0886eb4b47 100644 --- a/compiler/GHC/StgToJS/Profiling.hs +++ b/compiler/GHC/StgToJS/Profiling.hs @@ -26,7 +26,7 @@ where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Regs diff --git a/compiler/GHC/StgToJS/Regs.hs b/compiler/GHC/StgToJS/Regs.hs index ea482d4036..5e22158cb9 100644 --- a/compiler/GHC/StgToJS/Regs.hs +++ b/compiler/GHC/StgToJS/Regs.hs @@ -21,7 +21,7 @@ where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.Data.FastString diff --git a/compiler/GHC/StgToJS/Rts/Rts.hs b/compiler/GHC/StgToJS/Rts/Rts.hs index dbbac5d3b1..2f41862b6a 100644 --- a/compiler/GHC/StgToJS/Rts/Rts.hs +++ b/compiler/GHC/StgToJS/Rts/Rts.hs @@ -27,7 +27,7 @@ module GHC.StgToJS.Rts.Rts where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform @@ -314,11 +314,11 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . rts +rtsText = show . pretty . satJStat . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty $ rtsDecls +rtsDeclsText = show . pretty . satJStat $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' rts :: StgToJSConfig -> JStat diff --git a/compiler/GHC/StgToJS/Rts/Types.hs b/compiler/GHC/StgToJS/Rts/Types.hs index f1a0276d5d..81d4ccafa6 100644 --- a/compiler/GHC/StgToJS/Rts/Types.hs +++ b/compiler/GHC/StgToJS/Rts/Types.hs @@ -22,7 +22,7 @@ module GHC.StgToJS.Rts.Types where import GHC.Prelude import GHC.JS.Make -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.StgToJS.Regs import GHC.StgToJS.Types diff --git a/compiler/GHC/StgToJS/Stack.hs b/compiler/GHC/StgToJS/Stack.hs index 0250837f32..21e06f7585 100644 --- a/compiler/GHC/StgToJS/Stack.hs +++ b/compiler/GHC/StgToJS/Stack.hs @@ -66,7 +66,7 @@ where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Types diff --git a/compiler/GHC/StgToJS/StaticPtr.hs b/compiler/GHC/StgToJS/StaticPtr.hs index bddae1e674..1be82fe261 100644 --- a/compiler/GHC/StgToJS/StaticPtr.hs +++ b/compiler/GHC/StgToJS/StaticPtr.hs @@ -10,7 +10,7 @@ import GHC.Linker.Types (SptEntry(..)) import GHC.Fingerprint.Type import GHC.Types.Literal -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.StgToJS.Types diff --git a/compiler/GHC/StgToJS/Types.hs b/compiler/GHC/StgToJS/Types.hs index 2c01a30bf2..01e37e9f98 100644 --- a/compiler/GHC/StgToJS/Types.hs +++ b/compiler/GHC/StgToJS/Types.hs @@ -23,7 +23,8 @@ module GHC.StgToJS.Types where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Make import GHC.JS.Ppr () @@ -36,7 +37,7 @@ import GHC.Types.Var import GHC.Types.ForeignCall import Control.Monad.Trans.State.Strict -import GHC.Utils.Outputable (Outputable (..), text, SDocContext, (<+>), ($$)) +import GHC.Utils.Outputable (Outputable (..), text, SDocContext) import GHC.Data.FastString import GHC.Data.FastMutInt @@ -281,7 +282,6 @@ data StaticLit instance Outputable StaticLit where ppr x = text (show x) - instance ToJExpr StaticLit where toJExpr (BoolLit b) = toJExpr b toJExpr (IntLit i) = toJExpr i @@ -318,7 +318,7 @@ data ObjUnit = ObjUnit { oiSymbols :: ![FastString] -- ^ toplevel symbols (stored in index) , oiClInfo :: ![ClosureInfo] -- ^ closure information of all closures in block , oiStatic :: ![StaticInfo] -- ^ static closure data - , oiStat :: JStat -- ^ the code + , oiStat :: Sat.JStat -- ^ the code , oiRaw :: !BS.ByteString -- ^ raw JS code , oiFExports :: ![ExpFun] , oiFImports :: ![ForeignJSRef] @@ -353,16 +353,18 @@ data TypedExpr = TypedExpr , typex_expr :: [JExpr] } -instance Outputable TypedExpr where - ppr x = text "TypedExpr: " <+> ppr (typex_expr x) - $$ text "PrimReps: " <+> ppr (typex_typ x) +-- FIXME: temporarily removed until JStg replaces JStat +-- instance Outputable TypedExpr where +-- ppr x = text "TypedExpr: " <+> ppr (typex_expr x) +-- $$ text "PrimReps: " <+> ppr (typex_typ x) -- | A Primop result is either an inlining of some JS payload, or a primitive -- call to a JS function defined in Shim files in base. data PrimRes = PrimInline JStat -- ^ primop is inline, result is assigned directly | PRPrimCall JStat -- ^ primop is async call, primop returns the next - -- function to run. result returned to stack top in registers + -- function to run. result returned to stack top in + -- registers data ExprResult = ExprCont diff --git a/compiler/GHC/StgToJS/Utils.hs b/compiler/GHC/StgToJS/Utils.hs index 8d16f39a64..6bb7bed49a 100644 --- a/compiler/GHC/StgToJS/Utils.hs +++ b/compiler/GHC/StgToJS/Utils.hs @@ -12,16 +12,15 @@ import GHC.Prelude import GHC.StgToJS.Types import GHC.StgToJS.ExprCtx -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.Core.TyCon -import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable -assignToTypedExprs :: HasDebugCallStack => [TypedExpr] -> [JExpr] -> JStat +assignToTypedExprs :: [TypedExpr] -> [JExpr] -> JStat assignToTypedExprs tes es = assignAllEqual (concatMap typex_expr tes) es @@ -30,18 +29,19 @@ assignTypedExprs tes es = -- TODO: check primRep (typex_typ) here? assignToTypedExprs tes (concatMap typex_expr es) -assignToExprCtx :: HasDebugCallStack => ExprCtx -> [JExpr] -> JStat +assignToExprCtx :: ExprCtx -> [JExpr] -> JStat assignToExprCtx ctx es = assignToTypedExprs (ctxTarget ctx) es -- | Assign first expr only (if it exists), performing coercions between some -- PrimReps (e.g. StablePtr# and Addr#). -assignCoerce1 :: HasDebugCallStack => [TypedExpr] -> [TypedExpr] -> JStat +assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStat assignCoerce1 [x] [y] = assignCoerce x y assignCoerce1 [] [] = mempty -assignCoerce1 x y = pprPanic "assignCoerce1" +assignCoerce1 _x _y = pprPanic "assignCoerce1" (vcat [ text "lengths do not match" - , ppr x - , ppr y + -- FIXME: Outputable instance removed until JStg replaces JStat + -- , ppr x + -- , ppr y ]) -- | Assign p2 to p1 with optional coercion |