diff options
Diffstat (limited to 'compiler/GHC')
30 files changed, 887 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 |