diff options
author | doyougnu <jeffrey.young@iohk.io> | 2023-03-15 11:01:03 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-03-30 01:40:08 -0400 |
commit | b159e0e94f8d049198947965046b6a5edbd89c36 (patch) | |
tree | 4edd4755aed0d7c4043f6fa008acff8692a69549 | |
parent | 41a572f656c04770366c29ef5554184cf685482f (diff) | |
download | haskell-b159e0e94f8d049198947965046b6a5edbd89c36.tar.gz |
js: split JMacro into JS eDSL and JS syntax
This commit:
Splits JExpr and JStat into two nearly identical DSLs:
- GHC.JS.Syntax is the JMacro based DSL without unsaturation, i.e., a
value cannot be unsaturated, or, a value of this DSL is a witness that a
value of GHC.JS.Unsat has been saturated
- GHC.JS.Unsat is the JMacro DSL from GHCJS with Unsaturation.
Then all binary and outputable instances are changed to use
GHC.JS.Syntax.
This moves us closer to closing out #22736 and #22352. See #22736 for
roadmap.
-------------------------
Metric Increase:
CoOpt_Read
LargeRecord
ManyAlternatives
PmSeriesS
PmSeriesT
PmSeriesV
T10421
T10858
T11195
T11374
T11822
T12227
T12707
T13035
T13253
T13253-spj
T13379
T14683
T15164
T15703
T16577
T17096
T17516
T17836
T18140
T18282
T18304
T18478
T18698a
T18698b
T18923
T1969
T19695
T20049
T21839c
T3064
T4801
T5321FD
T5321Fun
T5631
T5642
T783
T9198
T9233
T9630
TcPlugin_RewritePerf
WWRec
-------------------------
31 files changed, 888 insertions, 455 deletions
diff --git a/compiler/GHC/JS/Make.hs b/compiler/GHC/JS/Make.hs index f57643094c..8b06198a83 100644 --- a/compiler/GHC/JS/Make.hs +++ b/compiler/GHC/JS/Make.hs @@ -131,7 +131,7 @@ where import GHC.Prelude hiding ((.|.)) -import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax import Control.Arrow ((***)) diff --git a/compiler/GHC/JS/Ppr.hs b/compiler/GHC/JS/Ppr.hs index 02529a928f..bb1acd9f51 100644 --- a/compiler/GHC/JS/Ppr.hs +++ b/compiler/GHC/JS/Ppr.hs @@ -56,11 +56,11 @@ x $$$ y = nest 2 $ x $+$ y -- | Render a syntax tree as a pretty-printable document -- (simply showing the resultant doc produces a nice, -- well formatted String). -renderJs :: (JsToDoc a, JMacro a) => a -> Doc +renderJs :: (JsToDoc a) => a -> Doc renderJs = renderJs' defaultRenderJs -renderJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc -renderJs' r = jsToDocR r . jsSaturate Nothing +renderJs' :: (JsToDoc a) => RenderJs -> a -> Doc +renderJs' r = jsToDocR r data RenderJs = RenderJs { renderJsS :: !(RenderJs -> JStat -> Doc) @@ -78,11 +78,11 @@ jsToDoc = jsToDocR defaultRenderJs -- | Render a syntax tree as a pretty-printable document, using a given prefix -- to all generated names. Use this with distinct prefixes to ensure distinct -- generated names between independent calls to render(Prefix)Js. -renderPrefixJs :: (JsToDoc a, JMacro a) => FastString -> a -> Doc -renderPrefixJs pfx = renderPrefixJs' defaultRenderJs pfx +renderPrefixJs :: (JsToDoc a, JMacro a) => a -> Doc +renderPrefixJs = renderPrefixJs' defaultRenderJs -renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> FastString -> a -> Doc -renderPrefixJs' r pfx = jsToDocR r . jsSaturate (Just $ "jmId_" `mappend` pfx) +renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc +renderPrefixJs' r = jsToDocR r braceNest :: Doc -> Doc braceNest x = char '{' <+> nest 2 x $$ char '}' @@ -108,15 +108,14 @@ instance JsToDoc [JStat] where defRenderJsS :: RenderJs -> JStat -> Doc defRenderJsS r = \case IfStat cond x y -> hangBrace (text "if" <> parens (jsToDocR r cond)) - (jsToDocR r x) - $$ mbElse + (jsToDocR r x) + $$ mbElse where mbElse | y == BlockStat [] = PP.empty | otherwise = hangBrace (text "else") (jsToDocR r y) DeclStat x Nothing -> text "var" <+> jsToDocR r x DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+> char '=' <+> jsToDocR r e WhileStat False p b -> hangBrace (text "while" <> parens (jsToDocR r p)) (jsToDocR r b) WhileStat True p b -> (hangBrace (text "do") (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p) - UnsatBlock e -> jsToDocR r $ pseudoSaturate e BreakStat l -> maybe (text "break") (\(LexicalFastString s) -> (text "break" <+> ftext s)) l ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s @@ -150,7 +149,7 @@ defRenderJsS r = \case -- }); -- ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] - _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x + _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x UOpStat op x | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x | isPre op -> ftext (uOpText op) <> optParens r x @@ -160,8 +159,8 @@ defRenderJsS r = \case flattenBlocks :: [JStat] -> [JStat] flattenBlocks = \case BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys - y:ys -> y : flattenBlocks ys - [] -> [] + y:ys -> y : flattenBlocks ys + [] -> [] optParens :: RenderJs -> JExpr -> Doc optParens r x = case x of @@ -180,7 +179,6 @@ defRenderJsE r = \case | isPre op -> ftext (uOpText op) <> optParens r x | otherwise -> optParens r x <> ftext (uOpText op) ApplExpr je xs -> jsToDocR r je <> (parens . hsep . punctuate comma $ map (jsToDocR r) xs) - UnsatExpr e -> jsToDocR r $ pseudoSaturate e defRenderJsV :: RenderJs -> JVal -> Doc defRenderJsV r = \case @@ -202,7 +200,6 @@ defRenderJsV r = \case -- because we sort the elements lexically $ sortOn (LexicalFastString . fst) (nonDetEltsUniqMap m) JFunc is b -> parens $ hangBrace (text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b) - UnsatVal f -> jsToDocR r $ pseudoSaturate f defRenderJsI :: RenderJs -> Ident -> Doc defRenderJsI _ (TxtI t) = ftext t @@ -235,7 +232,7 @@ encodeJsonChar = \case let h = showHex cp "" in text (prefix ++ replicate (pad - length h) '0' ++ h) -uOpText :: JUOp -> FastString +uOpText :: UOp -> FastString uOpText = \case NotOp -> "!" BNotOp -> "~" @@ -251,7 +248,7 @@ uOpText = \case PreDecOp -> "--" PostDecOp -> "--" -opText :: JOp -> FastString +opText :: Op -> FastString opText = \case EqOp -> "==" StrictEqOp -> "===" @@ -278,13 +275,13 @@ opText = \case InOp -> "in" -isPre :: JUOp -> Bool +isPre :: UOp -> Bool isPre = \case PostIncOp -> False PostDecOp -> False _ -> True -isAlphaOp :: JUOp -> Bool +isAlphaOp :: UOp -> Bool isAlphaOp = \case NewOp -> True TypeofOp -> True diff --git a/compiler/GHC/JS/Syntax.hs b/compiler/GHC/JS/Syntax.hs index 66067ced9e..0b8a6c05b2 100644 --- a/compiler/GHC/JS/Syntax.hs +++ b/compiler/GHC/JS/Syntax.hs @@ -48,92 +48,60 @@ -- GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides -- helper functions that use the deeply embedded DSL defined in this module -- to provide some of the benefits of a shallow embedding. +-- ----------------------------------------------------------------------------- + module GHC.JS.Syntax ( -- * Deeply embedded JS datatypes JStat(..) , JExpr(..) , JVal(..) - , JOp(..) - , JUOp(..) + , Op(..) + , UOp(..) , Ident(..) - , identFS - , JsLabel + , JLabel -- * pattern synonyms over JS operators - , pattern New - , pattern Not - , pattern Negate - , pattern Add - , pattern Sub - , pattern Mul - , pattern Div - , pattern Mod - , pattern BOr - , pattern BAnd - , pattern BXor - , pattern BNot - , pattern LOr - , pattern LAnd - , pattern Int - , pattern String - , pattern PreInc - , pattern PostInc - , pattern PreDec - , pattern PostDec - -- * Ident supply - , IdentSupply(..) - , newIdentSupply - , pseudoSaturate + , pattern JNew + , pattern JNot + , pattern JNegate + , pattern JAdd + , pattern JSub + , pattern JMul + , pattern JDiv + , pattern JMod + , pattern JBOr + , pattern JBAnd + , pattern JBXor + , pattern JBNot + , pattern JLOr + , pattern JLAnd + , pattern SatInt + , pattern JString + , pattern JPreInc + , pattern JPostInc + , pattern JPreDec + , pattern JPostDec -- * Utility , SaneDouble(..) + , jassignAll + , jassignAllEqual + , jvar ) where import GHC.Prelude +import GHC.JS.Unsat.Syntax (Ident(..)) +import GHC.Data.FastString +import GHC.Types.Unique.Map +import GHC.Utils.Misc + import Control.DeepSeq -import Data.Function import Data.Data -import Data.Word import qualified Data.Semigroup as Semigroup import GHC.Generics -import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict -import GHC.Types.Unique -import GHC.Types.Unique.Map - --- | A supply of identifiers, possibly empty -newtype IdentSupply a - = IS {runIdentSupply :: State [Ident] a} - deriving Typeable - -instance NFData (IdentSupply a) where rnf IS{} = () - -inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b -inIdentSupply f x = IS $ f (runIdentSupply x) - -instance Functor IdentSupply where - fmap f x = inIdentSupply (fmap f) x - -newIdentSupply :: Maybe FastString -> [Ident] -newIdentSupply Nothing = newIdentSupply (Just "jmId") -newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)]) - | x <- [(0::Word64)..] - ] - --- | Given a Pseudo-saturate a value with garbage @<<unsatId>>@ identifiers. -pseudoSaturate :: IdentSupply a -> a -pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<<unsatId>>") - -instance Eq a => Eq (IdentSupply a) where - (==) = (==) `on` pseudoSaturate -instance Ord a => Ord (IdentSupply a) where - compare = compare `on` pseudoSaturate -instance Show a => Show (IdentSupply a) where - show x = "(" ++ show (pseudoSaturate x) ++ ")" - -------------------------------------------------------------------------------- -- Statements @@ -142,26 +110,25 @@ instance Show a => Show (IdentSupply a) where -- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) -- for details data JStat - = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] - | ReturnStat JExpr -- ^ Return - | IfStat JExpr JStat JStat -- ^ If - | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True - | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True + = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JExpr -- ^ Return + | IfStat JExpr JStat JStat -- ^ If + | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch - | TryStat JStat Ident JStat JStat -- ^ Try - | BlockStat [JStat] -- ^ Blocks - | ApplStat JExpr [JExpr] -- ^ Application - | UOpStat JUOp JExpr -- ^ Unary operators - | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ - | UnsatBlock (IdentSupply JStat) -- ^ /Unsaturated/ blocks see 'pseudoSaturate' - | LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic - | BreakStat (Maybe JsLabel) -- ^ Break - | ContinueStat (Maybe JsLabel) -- ^ Continue + | TryStat JStat Ident JStat JStat -- ^ Try + | BlockStat [JStat] -- ^ Blocks + | ApplStat JExpr [JExpr] -- ^ Application + | UOpStat UOp JExpr -- ^ Unary operators + | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ + | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JLabel) -- ^ Break + | ContinueStat (Maybe JLabel) -- ^ Continue deriving (Eq, Typeable, Generic) -- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of -- course 'LabelStat' -type JsLabel = LexicalFastString +type JLabel = LexicalFastString instance Semigroup JStat where (<>) = appendJStat @@ -178,10 +145,10 @@ appendJStat :: JStat -> JStat -> JStat appendJStat mx my = case (mx,my) of (BlockStat [] , y ) -> y (x , BlockStat []) -> x - (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys - (BlockStat xs , ys ) -> BlockStat $ xs ++ [ys] - (xs , BlockStat ys) -> BlockStat $ xs : ys - (xs , ys ) -> BlockStat [xs,ys] + (BlockStat xs , BlockStat ys) -> BlockStat $! xs ++ ys + (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $! xs : ys + (xs , ys ) -> BlockStat [xs,ys] -------------------------------------------------------------------------------- @@ -189,16 +156,13 @@ appendJStat mx my = case (mx,my) of -------------------------------------------------------------------------------- -- | JavaScript Expressions data JExpr - = ValExpr JVal -- ^ All values are trivially expressions - | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' - | InfixExpr JOp JExpr JExpr -- ^ Infix Expressions, see 'JExpr' - -- pattern synonyms - | UOpExpr JUOp JExpr -- ^ Unary Expressions - | IfExpr JExpr JExpr JExpr -- ^ If-expression + | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms + | UOpExpr UOp JExpr -- ^ Unary Expressions + | IfExpr JExpr JExpr JExpr -- ^ If-expression | ApplExpr JExpr [JExpr] -- ^ Application - | UnsatExpr (IdentSupply JExpr) -- ^ An /Unsaturated/ expression. - -- See 'pseudoSaturate' deriving (Eq, Typeable, Generic) -- * Useful pattern synonyms to ease programming with the deeply embedded JS @@ -207,110 +171,110 @@ data JExpr -- and Integer literals. -- | pattern synonym for a unary operator new -pattern New :: JExpr -> JExpr -pattern New x = UOpExpr NewOp x +pattern JNew :: JExpr -> JExpr +pattern JNew x = UOpExpr NewOp x -- | pattern synonym for prefix increment @++x@ -pattern PreInc :: JExpr -> JExpr -pattern PreInc x = UOpExpr PreIncOp x +pattern JPreInc :: JExpr -> JExpr +pattern JPreInc x = UOpExpr PreIncOp x -- | pattern synonym for postfix increment @x++@ -pattern PostInc :: JExpr -> JExpr -pattern PostInc x = UOpExpr PostIncOp x +pattern JPostInc :: JExpr -> JExpr +pattern JPostInc x = UOpExpr PostIncOp x -- | pattern synonym for prefix decrement @--x@ -pattern PreDec :: JExpr -> JExpr -pattern PreDec x = UOpExpr PreDecOp x +pattern JPreDec :: JExpr -> JExpr +pattern JPreDec x = UOpExpr PreDecOp x -- | pattern synonym for postfix decrement @--x@ -pattern PostDec :: JExpr -> JExpr -pattern PostDec x = UOpExpr PostDecOp x +pattern JPostDec :: JExpr -> JExpr +pattern JPostDec x = UOpExpr PostDecOp x -- | pattern synonym for logical not @!@ -pattern Not :: JExpr -> JExpr -pattern Not x = UOpExpr NotOp x +pattern JNot :: JExpr -> JExpr +pattern JNot x = UOpExpr NotOp x -- | pattern synonym for unary negation @-@ -pattern Negate :: JExpr -> JExpr -pattern Negate x = UOpExpr NegOp x +pattern JNegate :: JExpr -> JExpr +pattern JNegate x = UOpExpr NegOp x -- | pattern synonym for addition @+@ -pattern Add :: JExpr -> JExpr -> JExpr -pattern Add x y = InfixExpr AddOp x y +pattern JAdd :: JExpr -> JExpr -> JExpr +pattern JAdd x y = InfixExpr AddOp x y -- | pattern synonym for subtraction @-@ -pattern Sub :: JExpr -> JExpr -> JExpr -pattern Sub x y = InfixExpr SubOp x y +pattern JSub :: JExpr -> JExpr -> JExpr +pattern JSub x y = InfixExpr SubOp x y -- | pattern synonym for multiplication @*@ -pattern Mul :: JExpr -> JExpr -> JExpr -pattern Mul x y = InfixExpr MulOp x y +pattern JMul :: JExpr -> JExpr -> JExpr +pattern JMul x y = InfixExpr MulOp x y -- | pattern synonym for division @*@ -pattern Div :: JExpr -> JExpr -> JExpr -pattern Div x y = InfixExpr DivOp x y +pattern JDiv :: JExpr -> JExpr -> JExpr +pattern JDiv x y = InfixExpr DivOp x y -- | pattern synonym for remainder @%@ -pattern Mod :: JExpr -> JExpr -> JExpr -pattern Mod x y = InfixExpr ModOp x y +pattern JMod :: JExpr -> JExpr -> JExpr +pattern JMod x y = InfixExpr ModOp x y -- | pattern synonym for Bitwise Or @|@ -pattern BOr :: JExpr -> JExpr -> JExpr -pattern BOr x y = InfixExpr BOrOp x y +pattern JBOr :: JExpr -> JExpr -> JExpr +pattern JBOr x y = InfixExpr BOrOp x y -- | pattern synonym for Bitwise And @&@ -pattern BAnd :: JExpr -> JExpr -> JExpr -pattern BAnd x y = InfixExpr BAndOp x y +pattern JBAnd :: JExpr -> JExpr -> JExpr +pattern JBAnd x y = InfixExpr BAndOp x y -- | pattern synonym for Bitwise XOr @^@ -pattern BXor :: JExpr -> JExpr -> JExpr -pattern BXor x y = InfixExpr BXorOp x y +pattern JBXor :: JExpr -> JExpr -> JExpr +pattern JBXor x y = InfixExpr BXorOp x y -- | pattern synonym for Bitwise Not @~@ -pattern BNot :: JExpr -> JExpr -pattern BNot x = UOpExpr BNotOp x +pattern JBNot :: JExpr -> JExpr +pattern JBNot x = UOpExpr BNotOp x -- | pattern synonym for logical Or @||@ -pattern LOr :: JExpr -> JExpr -> JExpr -pattern LOr x y = InfixExpr LOrOp x y +pattern JLOr :: JExpr -> JExpr -> JExpr +pattern JLOr x y = InfixExpr LOrOp x y -- | pattern synonym for logical And @&&@ -pattern LAnd :: JExpr -> JExpr -> JExpr -pattern LAnd x y = InfixExpr LAndOp x y - +pattern JLAnd :: JExpr -> JExpr -> JExpr +pattern JLAnd x y = InfixExpr LAndOp x y -- | pattern synonym to create integer values -pattern Int :: Integer -> JExpr -pattern Int x = ValExpr (JInt x) +pattern SatInt :: Integer -> JExpr +pattern SatInt x = ValExpr (JInt x) -- | pattern synonym to create string values -pattern String :: FastString -> JExpr -pattern String x = ValExpr (JStr x) +pattern JString :: FastString -> JExpr +pattern JString x = ValExpr (JStr x) -------------------------------------------------------------------------------- -- Values -------------------------------------------------------------------------------- + -- | JavaScript values data JVal - = JVar Ident -- ^ A variable reference - | JList [JExpr] -- ^ A JavaScript list, or what JS - -- calls an Array - | JDouble SaneDouble -- ^ A Double - | JInt Integer -- ^ A BigInt - | JStr FastString -- ^ A String - | JRegEx FastString -- ^ A Regex + = JVar Ident -- ^ A variable reference + | JList [JExpr] -- ^ A JavaScript list, or what JS calls an Array + | JDouble SaneDouble -- ^ A Double + | JInt Integer -- ^ A BigInt + | JStr FastString -- ^ A String + | JRegEx FastString -- ^ A Regex | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ - | JFunc [Ident] JStat -- ^ A function - | UnsatVal (IdentSupply JVal) -- ^ An /Unsaturated/ value, see 'pseudoSaturate' + | JFunc [Ident] JStat -- ^ A function deriving (Eq, Typeable, Generic) + -------------------------------------------------------------------------------- -- Operators -------------------------------------------------------------------------------- + -- | JS Binary Operators. We do not deeply embed the comma operator and the -- assignment operators -data JOp +data Op = EqOp -- ^ Equality: `==` | StrictEqOp -- ^ Strict Equality: `===` | NeqOp -- ^ InEquality: `!=` @@ -336,10 +300,10 @@ data JOp | InOp -- ^ @in@ deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) -instance NFData JOp +instance NFData Op -- | JS Unary Operators -data JUOp +data UOp = NotOp -- ^ Logical Not: @!@ | BNotOp -- ^ Bitwise Not: @~@ | NegOp -- ^ Negation: @-@ @@ -355,7 +319,7 @@ data JUOp | PostDecOp -- ^ Postfix Decrement: @x--@ deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) -instance NFData JUOp +instance NFData UOp -- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' -- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on @@ -376,17 +340,16 @@ instance Ord SaneDouble where instance Show SaneDouble where show (SaneDouble x) = show x - -------------------------------------------------------------------------------- --- Identifiers +-- Helper Functions -------------------------------------------------------------------------------- --- We use FastString for identifiers in JS backend --- | A newtype wrapper around 'FastString' for JS identifiers. -newtype Ident = TxtI { itxt :: FastString } - deriving stock (Show, Eq) - deriving newtype (Uniquable) +jassignAllEqual :: [JExpr] -> [JExpr] -> JStat +jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" AssignStat xs ys) + +jassignAll :: [JExpr] -> [JExpr] -> JStat +jassignAll xs ys = mconcat (zipWith AssignStat xs ys) + +jvar :: FastString -> JExpr +jvar = ValExpr . JVar . TxtI -identFS :: Ident -> FastString -identFS = \case - TxtI fs -> fs diff --git a/compiler/GHC/JS/Transform.hs b/compiler/GHC/JS/Transform.hs index 72b3980537..9051c04fbf 100644 --- a/compiler/GHC/JS/Transform.hs +++ b/compiler/GHC/JS/Transform.hs @@ -8,10 +8,7 @@ {-# LANGUAGE BlockArguments #-} module GHC.JS.Transform - ( mapIdent - , mapStatIdent - , mapExprIdent - , identsS + ( identsS , identsV , identsE -- * Saturation @@ -24,68 +21,25 @@ module GHC.JS.Transform , composOpM , composOpM_ , composOpFold + , satJExpr + , satJStat + , unsatJStat ) where import GHC.Prelude -import GHC.JS.Syntax +import qualified GHC.JS.Syntax as Sat +import GHC.JS.Unsat.Syntax import Data.Functor.Identity import Control.Monad -import Data.Bifunctor +import Control.Arrow ((***)) import GHC.Data.FastString import GHC.Utils.Monad.State.Strict import GHC.Types.Unique.Map -mapExprIdent :: (Ident -> JExpr) -> JExpr -> JExpr -mapExprIdent f = fst (mapIdent f) - -mapStatIdent :: (Ident -> JExpr) -> JStat -> JStat -mapStatIdent f = snd (mapIdent f) - --- | Map on every variable ident -mapIdent :: (Ident -> JExpr) -> (JExpr -> JExpr, JStat -> JStat) -mapIdent f = (map_expr, map_stat) - where - map_expr = \case - ValExpr v -> map_val v - SelExpr e i -> SelExpr (map_expr e) i - IdxExpr e1 e2 -> IdxExpr (map_expr e1) (map_expr e2) - InfixExpr o e1 e2 -> InfixExpr o (map_expr e1) (map_expr e2) - UOpExpr o e -> UOpExpr o (map_expr e) - IfExpr e1 e2 e3 -> IfExpr (map_expr e1) (map_expr e2) (map_expr e3) - ApplExpr e es -> ApplExpr (map_expr e) (fmap map_expr es) - UnsatExpr me -> UnsatExpr (fmap map_expr me) - - map_val v = case v of - JVar i -> f i - JList es -> ValExpr $ JList (fmap map_expr es) - JDouble{} -> ValExpr $ v - JInt{} -> ValExpr $ v - JStr{} -> ValExpr $ v - JRegEx{} -> ValExpr $ v - JHash me -> ValExpr $ JHash (fmap map_expr me) - JFunc is s -> ValExpr $ JFunc is (map_stat s) - UnsatVal v2 -> ValExpr $ UnsatVal v2 - - map_stat s = case s of - DeclStat i e -> DeclStat i (fmap map_expr e) - ReturnStat e -> ReturnStat (map_expr e) - IfStat e s1 s2 -> IfStat (map_expr e) (map_stat s1) (map_stat s2) - WhileStat b e s2 -> WhileStat b (map_expr e) (map_stat s2) - ForInStat b i e s2 -> ForInStat b i (map_expr e) (map_stat s2) - SwitchStat e les s2 -> SwitchStat (map_expr e) (fmap (bimap map_expr map_stat) les) (map_stat s2) - TryStat s2 i s3 s4 -> TryStat (map_stat s2) i (map_stat s3) (map_stat s4) - BlockStat ls -> BlockStat (fmap map_stat ls) - ApplStat e es -> ApplStat (map_expr e) (fmap map_expr es) - UOpStat o e -> UOpStat o (map_expr e) - AssignStat e1 e2 -> AssignStat (map_expr e1) (map_expr e2) - UnsatBlock ms -> UnsatBlock (fmap map_stat ms) - LabelStat l s2 -> LabelStat l (map_stat s2) - BreakStat{} -> s - ContinueStat{} -> s {-# INLINE identsS #-} identsS :: JStat -> [Ident] @@ -262,3 +216,203 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) _ -> composOpM go v + + +-------------------------------------------------------------------------------- +-- Translation +-- +-- This will be moved after GHC.JS.Syntax is removed +-------------------------------------------------------------------------------- +satJStat :: JStat -> Sat.JStat +satJStat = witness . proof + where proof = jsSaturate Nothing + + -- This is an Applicative but we can't use it because no type variables :( + witness :: JStat -> Sat.JStat + witness (DeclStat i rhs) = Sat.DeclStat i (fmap satJExpr rhs) + witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) + witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) + witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) + witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i + (satJExpr iter) + (witness body) + witness (SwitchStat struct ps def) = Sat.SwitchStat + (satJExpr struct) + (map (satJExpr *** witness) ps) + (witness def) + witness (TryStat t i c f) = Sat.TryStat (witness t) i (witness c) (witness f) + witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs + witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) + witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) + witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) + witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) + witness (BreakStat Nothing) = Sat.BreakStat Nothing + witness (BreakStat (Just l)) = Sat.BreakStat $! Just l + witness (ContinueStat Nothing) = Sat.ContinueStat Nothing + witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l + witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" + + +satJExpr :: JExpr -> Sat.JExpr +satJExpr = go + where + go (ValExpr v) = Sat.ValExpr (satJVal v) + go (SelExpr obj i) = Sat.SelExpr (satJExpr obj) i + go (IdxExpr o i) = Sat.IdxExpr (satJExpr o) (satJExpr i) + go (InfixExpr op l r) = Sat.InfixExpr (satJOp op) (satJExpr l) (satJExpr r) + go (UOpExpr op r) = Sat.UOpExpr (satJUOp op) (satJExpr r) + go (IfExpr c t e) = Sat.IfExpr (satJExpr c) (satJExpr t) (satJExpr e) + go (ApplExpr rator rands) = Sat.ApplExpr (satJExpr rator) (satJExpr <$> rands) + go UnsatExpr{} = error "satJExpr: discovered an Unsat...impossibly" + +satJOp :: JOp -> Sat.Op +satJOp = go + where + go EqOp = Sat.EqOp + go StrictEqOp = Sat.StrictEqOp + go NeqOp = Sat.NeqOp + go StrictNeqOp = Sat.StrictNeqOp + go GtOp = Sat.GtOp + go GeOp = Sat.GeOp + go LtOp = Sat.LtOp + go LeOp = Sat.LeOp + go AddOp = Sat.AddOp + go SubOp = Sat.SubOp + go MulOp = Sat.MulOp + go DivOp = Sat.DivOp + go ModOp = Sat.ModOp + go LeftShiftOp = Sat.LeftShiftOp + go RightShiftOp = Sat.RightShiftOp + go ZRightShiftOp = Sat.ZRightShiftOp + go BAndOp = Sat.BAndOp + go BOrOp = Sat.BOrOp + go BXorOp = Sat.BXorOp + go LAndOp = Sat.LAndOp + go LOrOp = Sat.LOrOp + go InstanceofOp = Sat.InstanceofOp + go InOp = Sat.InOp + +satJUOp :: JUOp -> Sat.UOp +satJUOp = go + where + go NotOp = Sat.NotOp + go BNotOp = Sat.BNotOp + go NegOp = Sat.NegOp + go PlusOp = Sat.PlusOp + go NewOp = Sat.NewOp + go TypeofOp = Sat.TypeofOp + go DeleteOp = Sat.DeleteOp + go YieldOp = Sat.YieldOp + go VoidOp = Sat.VoidOp + go PreIncOp = Sat.PreIncOp + go PostIncOp = Sat.PostIncOp + go PreDecOp = Sat.PreDecOp + go PostDecOp = Sat.PostDecOp + +satJVal :: JVal -> Sat.JVal +satJVal = go + where + go (JVar i) = Sat.JVar i + go (JList xs) = Sat.JList (satJExpr <$> xs) + go (JDouble d) = Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) + go (JInt i) = Sat.JInt i + go (JStr f) = Sat.JStr f + go (JRegEx f) = Sat.JRegEx f + go (JHash m) = Sat.JHash (satJExpr <$> m) + go (JFunc args body) = Sat.JFunc args (satJStat body) + go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" + +unsatJStat :: Sat.JStat -> JStat +unsatJStat = go_back + where + -- This is an Applicative but we can't use it because no type variables :( + go_back :: Sat.JStat -> JStat + go_back (Sat.DeclStat i rhs) = DeclStat i (fmap unsatJExpr rhs) + go_back (Sat.ReturnStat e) = ReturnStat (unsatJExpr e) + go_back (Sat.IfStat c t e) = IfStat (unsatJExpr c) (go_back t) (go_back e) + go_back (Sat.WhileStat is_do c e) = WhileStat is_do (unsatJExpr c) (go_back e) + go_back (Sat.ForInStat is_each i iter body) = ForInStat is_each i + (unsatJExpr iter) + (go_back body) + go_back (Sat.SwitchStat struct ps def) = SwitchStat + (unsatJExpr struct) + (map (unsatJExpr *** go_back) ps) + (go_back def) + go_back (Sat.TryStat t i c f) = TryStat (go_back t) i (go_back c) (go_back f) + go_back (Sat.BlockStat bs) = BlockStat $! fmap go_back bs + go_back (Sat.ApplStat rator rand) = ApplStat (unsatJExpr rator) (unsatJExpr <$> rand) + go_back (Sat.UOpStat rator rand) = UOpStat (unsatJUOp rator) (unsatJExpr rand) + go_back (Sat.AssignStat lhs rhs) = AssignStat (unsatJExpr lhs) (unsatJExpr rhs) + go_back (Sat.LabelStat lbl stmt) = LabelStat lbl (go_back stmt) + go_back (Sat.BreakStat Nothing) = BreakStat Nothing + go_back (Sat.BreakStat (Just l)) = BreakStat $! Just l + go_back (Sat.ContinueStat Nothing) = ContinueStat Nothing + go_back (Sat.ContinueStat (Just l)) = ContinueStat $! Just l + + +unsatJExpr :: Sat.JExpr -> JExpr +unsatJExpr = go + where + go (Sat.ValExpr v) = ValExpr (unsatJVal v) + go (Sat.SelExpr obj i) = SelExpr (unsatJExpr obj) i + go (Sat.IdxExpr o i) = IdxExpr (unsatJExpr o) (unsatJExpr i) + go (Sat.InfixExpr op l r) = InfixExpr (satOpToJOp op) (unsatJExpr l) (unsatJExpr r) + go (Sat.UOpExpr op r) = UOpExpr (unsatJUOp op) (unsatJExpr r) + go (Sat.IfExpr c t e) = IfExpr (unsatJExpr c) (unsatJExpr t) (unsatJExpr e) + go (Sat.ApplExpr rator rands) = ApplExpr (unsatJExpr rator) (unsatJExpr <$> rands) + +satOpToJOp :: Sat.Op -> JOp +satOpToJOp = go + where + go Sat.EqOp = EqOp + go Sat.StrictEqOp = StrictEqOp + go Sat.NeqOp = NeqOp + go Sat.StrictNeqOp = StrictNeqOp + go Sat.GtOp = GtOp + go Sat.GeOp = GeOp + go Sat.LtOp = LtOp + go Sat.LeOp = LeOp + go Sat.AddOp = AddOp + go Sat.SubOp = SubOp + go Sat.MulOp = MulOp + go Sat.DivOp = DivOp + go Sat.ModOp = ModOp + go Sat.LeftShiftOp = LeftShiftOp + go Sat.RightShiftOp = RightShiftOp + go Sat.ZRightShiftOp = ZRightShiftOp + go Sat.BAndOp = BAndOp + go Sat.BOrOp = BOrOp + go Sat.BXorOp = BXorOp + go Sat.LAndOp = LAndOp + go Sat.LOrOp = LOrOp + go Sat.InstanceofOp = InstanceofOp + go Sat.InOp = InOp + +unsatJUOp :: Sat.UOp -> JUOp +unsatJUOp = go + where + go Sat.NotOp = NotOp + go Sat.BNotOp = BNotOp + go Sat.NegOp = NegOp + go Sat.PlusOp = PlusOp + go Sat.NewOp = NewOp + go Sat.TypeofOp = TypeofOp + go Sat.DeleteOp = DeleteOp + go Sat.YieldOp = YieldOp + go Sat.VoidOp = VoidOp + go Sat.PreIncOp = PreIncOp + go Sat.PostIncOp = PostIncOp + go Sat.PreDecOp = PreDecOp + go Sat.PostDecOp = PostDecOp + +unsatJVal :: Sat.JVal -> JVal +unsatJVal = go + where + go (Sat.JVar i) = JVar i + go (Sat.JList xs) = JList (unsatJExpr <$> xs) + go (Sat.JDouble d) = JDouble (SaneDouble (Sat.unSaneDouble d)) + go (Sat.JInt i) = JInt i + go (Sat.JStr f) = JStr f + go (Sat.JRegEx f) = JRegEx f + go (Sat.JHash m) = JHash (unsatJExpr <$> m) + go (Sat.JFunc args body) = JFunc args (unsatJStat body) diff --git a/compiler/GHC/JS/Unsat/Syntax.hs b/compiler/GHC/JS/Unsat/Syntax.hs new file mode 100644 index 0000000000..f5ab076aa5 --- /dev/null +++ b/compiler/GHC/JS/Unsat/Syntax.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Unsat.Syntax +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Unsat.Syntax defines the Syntax for the JS backend in GHC. It +-- comports with the [ECMA-262](https://tc39.es/ecma262/) although not every +-- production rule of the standard is represented. Code in this module is a +-- fork of [JMacro](https://hackage.haskell.org/package/jmacro) (BSD 3 +-- Clause) by Gershom Bazerman, heavily modified to accomodate GHC's +-- constraints. +-- +-- +-- * Strategy +-- +-- Nothing fancy in this module, this is a classic deeply embeded AST for +-- JS. We define numerous ADTs and pattern synonyms to make pattern matching +-- and constructing ASTs easier. +-- +-- +-- * Consumers +-- +-- The entire JS backend consumes this module, e.g., the modules in +-- GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides +-- helper functions that use the deeply embedded DSL defined in this module +-- to provide some of the benefits of a shallow embedding. +----------------------------------------------------------------------------- +module GHC.JS.Unsat.Syntax + ( -- * Deeply embedded JS datatypes + JStat(..) + , JExpr(..) + , JVal(..) + , JOp(..) + , JUOp(..) + , Ident(..) + , identFS + , JsLabel + -- * pattern synonyms over JS operators + , pattern New + , pattern Not + , pattern Negate + , pattern Add + , pattern Sub + , pattern Mul + , pattern Div + , pattern Mod + , pattern BOr + , pattern BAnd + , pattern BXor + , pattern BNot + , pattern LOr + , pattern LAnd + , pattern Int + , pattern String + , pattern PreInc + , pattern PostInc + , pattern PreDec + , pattern PostDec + -- * Ident supply + , IdentSupply(..) + , newIdentSupply + , pseudoSaturate + -- * Utility + , SaneDouble(..) + ) where + +import GHC.Prelude + +import Control.DeepSeq + +import Data.Function +import Data.Data +import Data.Word +import qualified Data.Semigroup as Semigroup + +import GHC.Generics + +import GHC.Data.FastString +import GHC.Utils.Monad.State.Strict +import GHC.Types.Unique +import GHC.Types.Unique.Map + +-- | A supply of identifiers, possibly empty +newtype IdentSupply a + = IS {runIdentSupply :: State [Ident] a} + deriving Typeable + +instance NFData (IdentSupply a) where rnf IS{} = () + +inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b +inIdentSupply f x = IS $ f (runIdentSupply x) + +instance Functor IdentSupply where + fmap f x = inIdentSupply (fmap f) x + +newIdentSupply :: Maybe FastString -> [Ident] +newIdentSupply Nothing = newIdentSupply (Just "jmId") +newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)]) + | x <- [(0::Word64)..] + ] + +-- | Given a Pseudo-saturate a value with garbage @<<unsatId>>@ identifiers. +pseudoSaturate :: IdentSupply a -> a +pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<<unsatId>>") + +instance Eq a => Eq (IdentSupply a) where + (==) = (==) `on` pseudoSaturate +instance Ord a => Ord (IdentSupply a) where + compare = compare `on` pseudoSaturate +instance Show a => Show (IdentSupply a) where + show x = "(" ++ show (pseudoSaturate x) ++ ")" + + +-------------------------------------------------------------------------------- +-- Statements +-------------------------------------------------------------------------------- +-- | JavaScript statements, see the [ECMA262 +-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) +-- for details +data JStat + = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JExpr -- ^ Return + | IfStat JExpr JStat JStat -- ^ If + | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True + | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch + | TryStat JStat Ident JStat JStat -- ^ Try + | BlockStat [JStat] -- ^ Blocks + | ApplStat JExpr [JExpr] -- ^ Application + | UOpStat JUOp JExpr -- ^ Unary operators + | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ + | UnsatBlock (IdentSupply JStat) -- ^ /Unsaturated/ blocks see 'pseudoSaturate' + | LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JsLabel) -- ^ Break + | ContinueStat (Maybe JsLabel) -- ^ Continue + deriving (Eq, Typeable, Generic) + +-- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of +-- course 'LabelStat' +type JsLabel = LexicalFastString + +instance Semigroup JStat where + (<>) = appendJStat + +instance Monoid JStat where + mempty = BlockStat [] + +-- | Append a statement to another statement. 'appendJStat' only returns a +-- 'JStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty +-- 'BlockStat'. That is: +-- > (BlockStat [] , y ) = y +-- > (x , BlockStat []) = x +appendJStat :: JStat -> JStat -> JStat +appendJStat mx my = case (mx,my) of + (BlockStat [] , y ) -> y + (x , BlockStat []) -> x + (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys + (BlockStat xs , ys ) -> BlockStat $ xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $ xs : ys + (xs , ys ) -> BlockStat [xs,ys] + + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- +-- | JavaScript Expressions +data JExpr + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' + | InfixExpr JOp JExpr JExpr -- ^ Infix Expressions, see 'JExpr' + -- pattern synonyms + | UOpExpr JUOp JExpr -- ^ Unary Expressions + | IfExpr JExpr JExpr JExpr -- ^ If-expression + | ApplExpr JExpr [JExpr] -- ^ Application + | UnsatExpr (IdentSupply JExpr) -- ^ An /Saturated/ expression. + -- See 'pseudoSaturate' + deriving (Eq, Typeable, Generic) + +-- * Useful pattern synonyms to ease programming with the deeply embedded JS +-- AST. Each pattern wraps @JUOp@ and @JOp@ into a @JExpr@s to save typing and +-- for convienience. In addition we include a string wrapper for JS string +-- and Integer literals. + +-- | pattern synonym for a unary operator new +pattern New :: JExpr -> JExpr +pattern New x = UOpExpr NewOp x + +-- | pattern synonym for prefix increment @++x@ +pattern PreInc :: JExpr -> JExpr +pattern PreInc x = UOpExpr PreIncOp x + +-- | pattern synonym for postfix increment @x++@ +pattern PostInc :: JExpr -> JExpr +pattern PostInc x = UOpExpr PostIncOp x + +-- | pattern synonym for prefix decrement @--x@ +pattern PreDec :: JExpr -> JExpr +pattern PreDec x = UOpExpr PreDecOp x + +-- | pattern synonym for postfix decrement @--x@ +pattern PostDec :: JExpr -> JExpr +pattern PostDec x = UOpExpr PostDecOp x + +-- | pattern synonym for logical not @!@ +pattern Not :: JExpr -> JExpr +pattern Not x = UOpExpr NotOp x + +-- | pattern synonym for unary negation @-@ +pattern Negate :: JExpr -> JExpr +pattern Negate x = UOpExpr NegOp x + +-- | pattern synonym for addition @+@ +pattern Add :: JExpr -> JExpr -> JExpr +pattern Add x y = InfixExpr AddOp x y + +-- | pattern synonym for subtraction @-@ +pattern Sub :: JExpr -> JExpr -> JExpr +pattern Sub x y = InfixExpr SubOp x y + +-- | pattern synonym for multiplication @*@ +pattern Mul :: JExpr -> JExpr -> JExpr +pattern Mul x y = InfixExpr MulOp x y + +-- | pattern synonym for division @*@ +pattern Div :: JExpr -> JExpr -> JExpr +pattern Div x y = InfixExpr DivOp x y + +-- | pattern synonym for remainder @%@ +pattern Mod :: JExpr -> JExpr -> JExpr +pattern Mod x y = InfixExpr ModOp x y + +-- | pattern synonym for Bitwise Or @|@ +pattern BOr :: JExpr -> JExpr -> JExpr +pattern BOr x y = InfixExpr BOrOp x y + +-- | pattern synonym for Bitwise And @&@ +pattern BAnd :: JExpr -> JExpr -> JExpr +pattern BAnd x y = InfixExpr BAndOp x y + +-- | pattern synonym for Bitwise XOr @^@ +pattern BXor :: JExpr -> JExpr -> JExpr +pattern BXor x y = InfixExpr BXorOp x y + +-- | pattern synonym for Bitwise Not @~@ +pattern BNot :: JExpr -> JExpr +pattern BNot x = UOpExpr BNotOp x + +-- | pattern synonym for logical Or @||@ +pattern LOr :: JExpr -> JExpr -> JExpr +pattern LOr x y = InfixExpr LOrOp x y + +-- | pattern synonym for logical And @&&@ +pattern LAnd :: JExpr -> JExpr -> JExpr +pattern LAnd x y = InfixExpr LAndOp x y + + +-- | pattern synonym to create integer values +pattern Int :: Integer -> JExpr +pattern Int x = ValExpr (JInt x) + +-- | pattern synonym to create string values +pattern String :: FastString -> JExpr +pattern String x = ValExpr (JStr x) + + +-------------------------------------------------------------------------------- +-- Values +-------------------------------------------------------------------------------- +-- | JavaScript values +data JVal + = JVar Ident -- ^ A variable reference + | JList [JExpr] -- ^ A JavaScript list, or what JS + -- calls an Array + | JDouble SaneDouble -- ^ A Double + | JInt Integer -- ^ A BigInt + | JStr FastString -- ^ A String + | JRegEx FastString -- ^ A Regex + | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ + | JFunc [Ident] JStat -- ^ A function + | UnsatVal (IdentSupply JVal) -- ^ An /Saturated/ value, see 'pseudoSaturate' + deriving (Eq, Typeable, Generic) + +-------------------------------------------------------------------------------- +-- Operators +-------------------------------------------------------------------------------- +-- | JS Binary Operators. We do not deeply embed the comma operator and the +-- assignment operators +data JOp + = EqOp -- ^ Equality: `==` + | StrictEqOp -- ^ Strict Equality: `===` + | NeqOp -- ^ InEquality: `!=` + | StrictNeqOp -- ^ Strict InEquality `!==` + | GtOp -- ^ Greater Than: `>` + | GeOp -- ^ Greater Than or Equal: `>=` + | LtOp -- ^ Less Than: < + | LeOp -- ^ Less Than or Equal: <= + | AddOp -- ^ Addition: + + | SubOp -- ^ Subtraction: - + | MulOp -- ^ Multiplication \* + | DivOp -- ^ Division: \/ + | ModOp -- ^ Remainder: % + | LeftShiftOp -- ^ Left Shift: \<\< + | RightShiftOp -- ^ Right Shift: \>\> + | ZRightShiftOp -- ^ Unsigned RightShift: \>\>\> + | BAndOp -- ^ Bitwise And: & + | BOrOp -- ^ Bitwise Or: | + | BXorOp -- ^ Bitwise XOr: ^ + | LAndOp -- ^ Logical And: && + | LOrOp -- ^ Logical Or: || + | InstanceofOp -- ^ @instanceof@ + | InOp -- ^ @in@ + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData JOp + +-- | JS Unary Operators +data JUOp + = NotOp -- ^ Logical Not: @!@ + | BNotOp -- ^ Bitwise Not: @~@ + | NegOp -- ^ Negation: @-@ + | PlusOp -- ^ Unary Plus: @+x@ + | NewOp -- ^ new x + | TypeofOp -- ^ typeof x + | DeleteOp -- ^ delete x + | YieldOp -- ^ yield x + | VoidOp -- ^ void x + | PreIncOp -- ^ Prefix Increment: @++x@ + | PostIncOp -- ^ Postfix Increment: @x++@ + | PreDecOp -- ^ Prefix Decrement: @--x@ + | PostDecOp -- ^ Postfix Decrement: @x--@ + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData JUOp + +-- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' +-- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on +-- Sane-ness +newtype SaneDouble = SaneDouble + { unSaneDouble :: Double + } + deriving (Data, Typeable, Fractional, Num, Generic, NFData) + +instance Eq SaneDouble where + (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y) + +instance Ord SaneDouble where + compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y) + where fromNaN z | isNaN z = Nothing + | otherwise = Just z + +instance Show SaneDouble where + show (SaneDouble x) = show x + + +-------------------------------------------------------------------------------- +-- Identifiers +-------------------------------------------------------------------------------- +-- We use FastString for identifiers in JS backend + +-- | A newtype wrapper around 'FastString' for JS identifiers. +newtype Ident = TxtI { itxt :: FastString } + deriving stock (Show, Eq) + deriving newtype (Uniquable) + +identFS :: Ident -> FastString +identFS = \case + TxtI fs -> fs 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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 2f37328c39..105d44ef99 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -524,6 +524,7 @@ Library GHC.JS.Ppr GHC.JS.Syntax GHC.JS.Transform + GHC.JS.Unsat.Syntax GHC.Linker GHC.Linker.Config GHC.Linker.Dynamic |