diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Driver/Config/StgToJS.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/JS/Make.hs | 75 | ||||
| -rw-r--r-- | compiler/GHC/JS/Rts/Apply.hs | 752 | ||||
| -rw-r--r-- | compiler/GHC/JS/Rts/Rts.hs | 668 | ||||
| -rw-r--r-- | compiler/GHC/JS/Rts/Types.hs | 104 | ||||
| -rw-r--r-- | compiler/GHC/JS/Syntax.hs | 34 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/CoreUtils.hs | 93 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/DataCon.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Expr.hs | 53 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Heap.hs | 86 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Monad.hs | 22 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Prim.hs | 29 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Profiling.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Regs.hs | 37 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/Types.hs | 32 | ||||
| -rw-r--r-- | compiler/GHC/StgToJS/UnitUtils.hs | 8 |
16 files changed, 1933 insertions, 76 deletions
diff --git a/compiler/GHC/Driver/Config/StgToJS.hs b/compiler/GHC/Driver/Config/StgToJS.hs index 69bb27953c..b94d3fcaa7 100644 --- a/compiler/GHC/Driver/Config/StgToJS.hs +++ b/compiler/GHC/Driver/Config/StgToJS.hs @@ -3,14 +3,18 @@ module GHC.Driver.Config.StgToJS ) where -import GHC.Prelude +import GHC.StgToJS.Types + import GHC.Driver.Session import GHC.Platform.Ways -import GHC.StgToJS.Types +import GHC.Utils.Outputable + +import GHC.Prelude -- | Initialize StgToJS settings from DynFlags initStgToJSConfig :: DynFlags -> StgToJSConfig initStgToJSConfig dflags = StgToJSConfig + -- flags { csInlinePush = False , csInlineBlackhole = False , csInlineLoadRegs = False @@ -22,4 +26,6 @@ initStgToJSConfig dflags = StgToJSConfig , csTraceForeign = False , csProf = ways dflags `hasWay` WayProf , csRuntimeAssert = False + -- settings + , csContext = initSDocContext dflags defaultDumpStyle } diff --git a/compiler/GHC/JS/Make.hs b/compiler/GHC/JS/Make.hs index 2987e1a1a9..07659c664f 100644 --- a/compiler/GHC/JS/Make.hs +++ b/compiler/GHC/JS/Make.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -6,13 +5,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE PatternSynonyms #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JExpr -- | Helpers to create JS syntax values module GHC.JS.Make ( ToJExpr (..) , ToStat (..) , var + , jString -- * Literals , null_ , undefined_ @@ -31,8 +32,9 @@ module GHC.JS.Make , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) , (.>.), (.>=.), (.<.), (.<=.) , (.<<.), (.>>.), (.>>>.) - , (.||.), (.&&.) + , (.|.), (.||.), (.&&.) , if_, if10, if01, ifS, ifBlockS + , jwhenS , app, appS, returnS , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally , loop, loopBlockS @@ -46,10 +48,15 @@ module GHC.JS.Make , returnStack, assignAllEqual, assignAll , declAssignAll , nullStat, (.^) + -- * Math functions + , math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, + math_atan, math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh + -- * Statement helpers + , decl ) where -import GHC.Prelude +import GHC.Prelude hiding ((.|.)) import GHC.JS.Syntax @@ -70,7 +77,6 @@ import GHC.Utils.Misc ToJExpr Class --------------------------------------------------------------------} - -- | Things that can be marshalled into javascript values. -- Instantiate for any necessary data structures. class ToJExpr a where @@ -201,17 +207,25 @@ jTryCatchFinally s f s2 = UnsatBlock . IS $ do var :: ShortText -> JExpr var = ValExpr . JVar . TxtI +-- | Convert a ShortText to a Javascript String +jString :: ShortText -> JExpr +jString = toJExpr + jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b'] where b' = case toStat b of BlockStat xs -> BlockStat $ xs ++ [after] x -> BlockStat [x,after] +-- | construct a js declaration with the given identifier +decl :: Ident -> JStat +decl i = DeclStat i + jhEmpty :: M.Map k JExpr jhEmpty = M.empty jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr -jhSingle k v = jhAdd k v $ jhEmpty +jhSingle k v = jhAdd k v jhEmpty jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr -> M.Map k JExpr jhAdd k v m = M.insert k (toJExpr v) m @@ -244,7 +258,8 @@ infixl 6 .==., .===., .!=., .!==. infixl 7 .>., .>=., .<., .<=. -(.||.), (.&&.) :: JExpr -> JExpr -> JExpr +(.|.), (.||.), (.&&.) :: JExpr -> JExpr -> JExpr +(.|.) = InfixExpr BOrOp (.||.) = InfixExpr LOrOp (.&&.) = InfixExpr LAndOp @@ -268,6 +283,10 @@ if_ e1 e2 e3 = IfExpr e1 e2 e3 ifS :: JExpr -> JStat -> JStat -> JStat ifS e s1 s2 = IfStat e s1 s2 +-- if(e) { s1 } else { } +jwhenS :: JExpr -> JStat -> JStat +jwhenS cond block = ifS cond block mempty + -- if(e) { s1 } else { s2 } ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat ifBlockS e s1 s2 = IfStat e (mconcat s1) (mconcat s2) @@ -280,6 +299,7 @@ if10 e = IfExpr e one_ zero_ if01 :: JExpr -> JExpr if01 e = IfExpr e zero_ one_ +-- | an expression application; app f xs <==> f(xs) app :: ShortText -> [JExpr] -> JExpr app f xs = ApplExpr (var f) xs @@ -459,4 +479,43 @@ takeOneIdent = do return x _ -> error "takeOneIdent: empty list" - +-------------------------------------------------------------------------------- +-- Math functions +-------------------------------------------------------------------------------- +math :: JExpr +math = var "Math" + +math_ :: ShortText -> [JExpr] -> JExpr +math_ op args = ApplExpr (math .^ op) args + +math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan, + math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, math_sign + :: [JExpr] -> JExpr +math_log = math_ "log" +math_sin = math_ "sin" +math_cos = math_ "cos" +math_tan = math_ "tan" +math_exp = math_ "exp" +math_acos = math_ "acos" +math_asin = math_ "asin" +math_atan = math_ "atan" +math_abs = math_ "abs" +math_pow = math_ "pow" +math_sign = math_ "sign" +math_sqrt = math_ "sqrt" +math_asinh = math_ "asinh" +math_acosh = math_ "acosh" +math_atanh = math_ "atanh" + +instance Num JExpr where + x + y = InfixExpr AddOp x y + x - y = InfixExpr SubOp x y + x * y = InfixExpr MulOp x y + abs x = math_abs [x] + negate x = UOpExpr NegOp x + signum x = math_sign [x] + fromInteger x = ValExpr (JInt x) + +instance Fractional JExpr where + x / y = InfixExpr DivOp x y + fromRational x = ValExpr (JDouble (realToFrac x)) diff --git a/compiler/GHC/JS/Rts/Apply.hs b/compiler/GHC/JS/Rts/Apply.hs new file mode 100644 index 0000000000..02aa575efa --- /dev/null +++ b/compiler/GHC/JS/Rts/Apply.hs @@ -0,0 +1,752 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Rts.Apply +-- 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> +-- Stability : experimental +-- +-- Generate various apply functions for the RTS, for speeding up +-- function application in the most common cases. The code is generated +-- because it contains lots of repeating patterns, and to make it more +-- flexible when changing the RTS (for example how arguments are passed) +-- +-- The code in here can be a bit hard to read due to all the generated +-- low-level access things. Reading rts.js for a compiled program can be +-- easier (the file is always the same unless you change low-level RTS +-- options) +-- +-- FIXME: add selector thunks and let the gc follow them +----------------------------------------------------------------------------- + +module GHC.JS.Rts.Apply where + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Rts.Types + +import GHC.StgToJS.DataCon +import GHC.StgToJS.Heap +import GHC.StgToJS.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.Types + +import GHC.Types.CostCentre +import GHC.Data.ShortText + +import qualified Data.Bits as Bits +import Data.Semigroup ((<>)) +import GHC.Prelude hiding ((.|.)) + +rtsApply :: StgToJSConfig -> JStat +rtsApply cfg = mconcat $ + map (uncurry (stackApply cfg)) applySpec + ++ map (uncurry (fastApply cfg)) applySpec + ++ map (pap cfg) specPap + ++ [ mkApplyArr + , genericStackApply cfg + , genericFastApply cfg + , zeroApply cfg + , updates cfg + , papGen cfg + , moveRegs2 + , selectors cfg + ] + +-- specialized apply for these +-- make sure that once you are in spec, you stay there +applySpec :: [(Int,Int)] -- regs,arity +applySpec = [ (regs,arity) | arity <- [1..4], regs <- [max 0 (arity-1)..(arity*2)]] + +specApply :: Bool -> Int -> Int -> Maybe JExpr +specApply fast n r + | (r,n) == (0,0) = Just (toJExpr . TxtI . pack $ "h$ap_0_0" ++ fastSuff) + | (r,n) == (0,1) = Just (toJExpr . TxtI . pack $ "h$ap_1_0" ++ fastSuff) + | (r,n) `elem` applySpec = + Just (toJExpr . TxtI . pack $ "h$ap_" ++ show n ++ "_" ++ show r ++ fastSuff) + | otherwise = Nothing + where + fastSuff | fast = "_fast" + | otherwise = "" +{- + Build arrays to quickly lookup apply functions, getting the fast variant when possible + - h$apply[r << 8 | n] = function application for r regs, n args + - h$paps[r] = partial application for r registers (number of args is in the object) + -} + -- FIXME (Jeff, 2022/03): Perf: This code would benefit a great deal by using + -- a datastucture that supports fast merging. +mkApplyArr :: JStat +mkApplyArr = mconcat + [ TxtI "h$apply" ||= toJExpr (JList mempty) + , TxtI "h$paps" ||= toJExpr (JList mempty) + , (var "h$initStatic" .^ "push") `ApplStat` + [ValExpr (JFunc [] + (jVar (\i -> mconcat + [ i |= 0 + , WhileStat False (i .<. 65536) + ((var "h$apply" .! i |= var "h$ap_gen") + <> UOpStat PreIncOp i) + , i |= 0 + , WhileStat False (i .<. 128) + ((var "h$paps" .! i |= var "h$pap_gen") + <> UOpStat PreIncOp i) + , var "h$apply" .! 0 |= var "h$ap_0_0" + , mconcat (map assignSpec applySpec) + , mconcat (map assignPap specPap) + ]))) + ]] + where + assignSpec :: (Int, Int) -> JStat + assignSpec (r,n) = + var "h$apply" .! toJExpr (Bits.shiftL r 8 Bits..|. n) |= + toJExpr (TxtI . pack $ "h$ap_" ++ show n ++ "_" ++ show r) + + assignPap :: Int -> JStat + assignPap p = var "h$paps" .! toJExpr p |= + toJExpr (TxtI . pack $ "h$pap_" ++ show p) + +-- generic stack apply that can do everything, but less efficiently +-- on stack: tag: (regs << 8 | arity) +-- fixme: set closure info of stack frame +genericStackApply :: StgToJSConfig -> JStat +genericStackApply s = + closure (ClosureInfo "h$ap_gen" (CIRegs 0 [PtrV]) "h$ap_gen" CILayoutVariable CIStackFrame mempty) + (jVar $ \cf -> + mconcat [ traceRts s (jString "h$ap_gen") + , cf |= r1 .^ "f" + , SwitchStat (cf .^ "t") + [ (toJExpr Thunk, profStat s pushRestoreCCS <> returnS cf) + , (toJExpr Fun, funCase cf (funArity' cf)) + , (toJExpr Pap, funCase cf (papArity r1)) + , (toJExpr Blackhole, push' s [r1, var "h$return"] + <> returnS (app "h$blockOnBlackhole" [r1])) + ] (appS "throw" [jString "h$ap_gen: unexpected closure type " + (cf .^ "t")]) + ] + ) + where + funCase c arity = + jVar $ \myArity ar myAr myRegs regs newTag newAp p dat -> + mconcat [ myArity |= stack .! (sp - 1) + , ar |= mask8 arity + , myAr |= mask8 myArity + , myRegs |= myArity .>>. 8 + , traceRts s (jString "h$ap_gen: args: " + myAr + + jString " regs: " + myRegs) + , ifS (myAr .===. ar) + -- then + (traceRts s (jString "h$ap_gen: exact") + <> loop 0 (.<. myRegs) + (\i -> appS "h$setReg" [i+2, stack .! (sp-2-i)] + <> postIncrS i) + <> (sp |= sp - myRegs - 2) + <> returnS c) + -- else + (ifS (myAr .>. ar) + --then + (mconcat [ regs |= arity .>>. 8 + , traceRts s (jString "h$ap_gen: oversat: arity: " + ar + + jString " regs: " + regs) + , loop 0 (.<. regs) + (\i -> traceRts s (jString "h$ap_gen: loading register: " + i) + <> appS "h$setReg" [i+2, stack .! (sp-2-i)] + <> postIncrS i) + , newTag |= ((myRegs-regs).<<.8).|.myAr - ar + , newAp |= var "h$apply" .! newTag + , traceRts s (jString "h$ap_gen: next: " + (newAp .^ "n")) + , ifS (newAp .===. var "h$ap_gen") + ((sp |= sp - regs) <> (stack .! (sp - 1) |= newTag)) + (sp |= sp - regs - 1) + , stack .! sp |= newAp + , profStat s pushRestoreCCS + , returnS c + ]) + -- else + (traceRts s (jString "h$ap_gen: undersat") + <> mconcat [ p |= var "h$paps" .! myRegs + , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr] + , loop 0 (.<. myRegs) + (\i -> (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)] + <> postIncrS i) + , sp |= sp - myRegs - 2 + , r1 |= initClosure s p dat jCurrentCCS + , returnStack + ])) + ] + +{- + generic fast apply: can handle anything (slowly) + signature tag in argument +-} +genericFastApply :: StgToJSConfig -> JStat +genericFastApply s = + TxtI "h$ap_gen_fast" ||= jLam (\tag -> jVar (\c -> + mconcat [traceRts s (jString "h$ap_gen_fast: " + tag) + , c |= r1 .^ "f" + , SwitchStat (c .^ "t") + [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk") + <> pushStackApply c tag + <> returnS c) + , (toJExpr Fun, jVar (\farity -> + (farity |= funArity' c) + <> traceRts s (jString "h$ap_gen_fast: fun " + farity) + <> funCase c tag farity)) + , (toJExpr Pap, jVar (\parity -> + (parity |= papArity r1) + <> traceRts s (jString "h$ap_gen_fast: pap " + parity) + <> funCase c tag parity) + ) + , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con") + <> jwhenS (tag .!=. 0) + (appS "throw" [jString "h$ap_gen_fast: invalid apply"]) + <> returnS c) + , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole") + <> pushStackApply c tag + <> push' s [r1, var "h$return"] + <> returnS (app "h$blockOnBlackhole" [r1])) + ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + c .^ "t"] + ])) + + where + -- thunk: push everything to stack frame, enter thunk first + pushStackApply :: JExpr -> JExpr -> JStat + pushStackApply _c tag = + jVar $ \ap -> + mconcat [ pushAllRegs tag + , ap |= var "h$apply" .! tag + , ifS (ap .===. var "h$ap_gen") + ((sp |= sp + 2) <> (stack .! (sp-1) |= tag)) + (sp |= sp + 1) + , stack .! sp |= ap + , profStat s pushRestoreCCS + ] + + funCase :: JExpr -> JExpr -> JExpr -> JStat + funCase c tag arity = + jVar $ \ar myAr myRegs regsStart newTag newAp dat p -> + mconcat [ ar |= mask8 arity + , myAr |= mask8 tag + , myRegs |= tag .>>. 8 + , traceRts s (jString "h$ap_gen_fast: args: " + myAr + + jString " regs: " + myRegs) + , ifS (myAr .===. ar) + -- call the function directly + (traceRts s (jString "h$ap_gen_fast: exact") <> returnS c) + (ifS (myAr .>. ar) + -- push stack frame with remaining args, then call fun + (mconcat [ traceRts s (jString "h$ap_gen_fast: oversat " + sp) + , regsStart |= (arity .>>. 8) + 1 + , sp |= sp + myRegs - regsStart + 1 + , traceRts s (jString "h$ap_gen_fast: oversat " + sp) + , pushArgs regsStart myRegs + , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar + , newAp |= var "h$apply" .! newTag + , ifS (newAp .===. var "h$ap_gen") + ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag)) + (sp |= sp + 1) + , stack .! sp |= newAp + , profStat s pushRestoreCCS + , returnS c + ]) + -- else + (traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag) + <> jwhenS (tag .!=. 0) + (mconcat [p |= var "h$paps" .! myRegs + , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr] + , loop 0 (.<. myRegs) + (\i -> (dat .^ "push") + `ApplStat` [app "h$getReg" [i+2]] <> postIncrS i) + , r1 |= initClosure s p dat jCurrentCCS + ]) + <> returnStack)) + ] + + + pushAllRegs :: JExpr -> JStat + pushAllRegs tag = + jVar $ \regs -> + mconcat [regs |= tag .>>. 8 + , sp |= sp + regs + , SwitchStat regs (map pushReg [65,64..2]) mempty + ] + where + pushReg :: Int -> (JExpr, JStat) + pushReg r = (toJExpr (r-1), stack .! (sp - toJExpr (r - 2)) |= toJExpr (intToJSReg r)) + + pushArgs :: JExpr -> JExpr -> JStat + pushArgs start end = + loop end (.>=.start) (\i -> traceRts s (jString "pushing register: " + i) + <> (stack .! (sp + start - i) |= app "h$getReg" [i+1]) + <> postDecrS i + ) + +stackApply :: StgToJSConfig + -> Int -- ^ number of registers in stack frame + -> Int -- ^ number of arguments + -> JStat +stackApply s r n = + closure (ClosureInfo funcName (CIRegs 0 [PtrV]) funcName layout CIStackFrame mempty) + body + where + layout = CILayoutUnknown r + + funcName = pack ("h$ap_" ++ show n ++ "_" ++ show r) + + body = jVar $ + \c -> + mconcat [ c |= r1 .^ "f" + , traceRts s (toJExpr funcName + + jString " " + + (c .^ "n") + + jString " sp: " + sp + + jString " a: " + (c .^ "a")) + , SwitchStat (c .^ "t") + [ (toJExpr Thunk, traceRts s (toJExpr $ funcName <> ": thunk") <> profStat s pushRestoreCCS <> returnS c) + , (toJExpr Fun, traceRts s (toJExpr $ funcName <> ": fun") <> funCase c) + , (toJExpr Pap, traceRts s (toJExpr $ funcName <> ": pap") <> papCase c) + , (toJExpr Blackhole, push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1])) + ] (appS "throw" [toJExpr ("panic: " <> funcName <> ", unexpected closure type: ") + (c .^ "t")]) + ] + + funExact c = popSkip' 1 (reverse $ take r (map toJExpr $ enumFrom R2)) <> returnS c + stackArgs = map (\x -> stack .! (sp - toJExpr x)) [1..r] + + papCase :: JExpr -> JStat + papCase c = jVar $ \expr arity0 arity -> + case expr of + ValExpr (JVar pap) -> mconcat [ arity0 |= papArity r1 + , arity |= mask8 arity0 + , traceRts s (toJExpr (funcName <> ": found pap, arity: ") + arity) + , ifS (toJExpr n .===. arity) + --then + (traceRts s (toJExpr (funcName <> ": exact")) <> funExact c) + -- else + (ifS (toJExpr n .>. arity) + (traceRts s (toJExpr (funcName <> ": oversat")) <> oversatCase c arity0 arity) + (traceRts s (toJExpr (funcName <> ": undersat")) + <> mkPap s pap r1 (toJExpr n) stackArgs -- FIXME do we want double pap? + <> (sp |= sp - toJExpr (r + 1)) + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty -- FIXME: Jeff (2022,03), just quieting non-exhaustive + -- patterns. That the code wants to do this + -- means we should be encoding that funCase is + -- only callable on ValExpr (JVar pap)'s in + -- the type system, perhaps with a GADT or + -- phantom + + + funCase :: JExpr -> JStat + funCase c = jVar $ \expr ar0 ar -> + case expr of + ValExpr (JVar pap) -> mconcat [ ar0 |= funArity' c + , ar |= mask8 ar0 + , ifS (toJExpr n .===. ar) + (traceRts s (toJExpr (funcName <> ": exact")) <> funExact c) + (ifS (toJExpr n .>. ar) + (traceRts s (toJExpr (funcName <> ": oversat")) + <> oversatCase c ar0 ar) + (traceRts s (toJExpr (funcName <> ": undersat")) + <> mkPap s pap (toJExpr R1) (toJExpr n) stackArgs + <> (sp |= sp - toJExpr (r+1)) + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty -- FIXME: Jeff (2022,03), just quieting non-exhaustive + -- patterns. That the code wants to do this + -- means we should be encoding that funCase is + -- only callable on ValExpr (JVar pap)'s in + -- the type system, perhaps with a GADT or + -- phantom + + + -- oversat: call the function but keep enough on the stack for the next + oversatCase :: JExpr -- function + -> JExpr -- the arity tag + -> JExpr -- real arity (arity & 0xff) + -> JStat + oversatCase c arity arity0 = + jVar (\rs newAp -> + mconcat [ rs |= (arity .>>. 8) + , loadRegs rs + , sp |= sp - rs + , newAp |= (var "h$apply" .! (toJExpr n-arity0.|.((toJExpr r-rs).<<.8))) + , stack .! sp |= newAp + , profStat s pushRestoreCCS + , traceRts s (toJExpr (funcName <> ": new stack frame: ") + (newAp .^ "n")) + , returnS c + ]) + where + loadRegs rs = SwitchStat rs switchAlts mempty + where + switchAlts = map (\x -> (toJExpr x, toJExpr (intToJSReg (x+1)) |= stack .! (sp - toJExpr x))) [r,r-1..1] + +{- + stg_ap_r_n_fast is entered if a function of unknown arity + is called, n arguments are already in r registers +-} +fastApply :: StgToJSConfig -> Int -> Int -> JStat +fastApply s r n = func ||= toJExpr (JFunc myFunArgs body) + where + funName = pack ("h$ap_" ++ show n ++ "_" ++ show r ++ "_fast") + func = TxtI funName + + myFunArgs = [] + + regArgs = take r (enumFrom R2) + + mkAp :: Int -> Int -> [JExpr] + mkAp n' r' = [ var . pack $ "h$ap_" ++ show n' ++ "_" ++ show r' ] + + body = + jVar $ \c farity arity -> + mconcat [ c |= r1 .^ "f" + , traceRts s (toJExpr (funName <> ": sp ") + sp) + -- TODO: Jeff (2022,03): factor our and dry out this code + , SwitchStat (c .^ "t") + [(toJExpr Fun, traceRts s (toJExpr (funName <> ": ") + + clName c + + jString " (arity: " + (c .^ "a") + jString ")") + <> (farity |= funArity' c) + <> funCase c farity) + ,(toJExpr Pap, traceRts s (toJExpr (funName <> ": pap")) <> (arity |= papArity r1) <> funCase c arity) + ,(toJExpr Thunk, traceRts s (toJExpr (funName <> ": thunk")) <> push' s (reverse (map toJExpr $ take r (enumFrom R2)) ++ mkAp n r) <> profStat s pushRestoreCCS <> returnS c) + ,(toJExpr Blackhole, traceRts s (toJExpr (funName <> ": blackhole")) <> push' s (reverse (map toJExpr $ take r (enumFrom R2)) ++ mkAp n r) <> push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))] + (appS "throw" [toJExpr (funName <> ": unexpected closure type: ") + c .^ "t"]) + ] + + funCase :: JExpr -> JExpr -> JStat + funCase c arity = jVar $ + \arg ar -> case arg of + ValExpr (JVar pap) -> (ar |= mask8 arity) + <> ifS (toJExpr n .===. ar) + -- then + (traceRts s (toJExpr (funName <> ": exact")) <> returnS c) + -- else + (ifS (toJExpr n .>. ar) + --then + (traceRts s (toJExpr (funName <> ": oversat")) <> oversatCase c arity) + -- else + (traceRts s (toJExpr (funName <> ": undersat")) + <> mkPap s pap r1 (toJExpr n) (map toJExpr regArgs) + <> (r1 |= toJExpr pap) + <> returnStack)) + _ -> mempty -- FIXME: Jeff (2022,03), just quieting non-exhaustive + -- patterns. That the code wants to do this + -- means we should be encoding that funCase is + -- only callable on ValExpr (JVar pap)'s in + -- the type system, perhaps with a GADT or + -- phantom + + oversatCase :: JExpr -> JExpr -> JStat + oversatCase c arity = + jVar $ \rs rsRemain -> + mconcat [ rs |= arity .>>. 8 + , rsRemain |= toJExpr r - rs + , traceRts s (toJExpr + (funName <> " regs oversat ") + + rs + + jString " remain: " + + rsRemain) + , saveRegs rs + , sp |= sp + rsRemain + 1 + , stack .! sp |= var "h$apply" .! ((rsRemain.<<.8).|. toJExpr n - mask8 arity) + , profStat s pushRestoreCCS + , returnS c + ] + where + saveRegs n = SwitchStat n switchAlts mempty + where + switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (r-x)) |= toJExpr (intToJSReg (x+2)))) [0..r-1] + +zeroApply :: StgToJSConfig -> JStat +zeroApply s = + mconcat [ TxtI "h$ap_0_0_fast" ||= jLam (enter s r1) + , closure (ClosureInfo "h$ap_0_0" (CIRegs 0 [PtrV]) "h$ap_0_0" (CILayoutFixed 0 []) CIStackFrame mempty) + (adjSpN' 1 <> enter s r1) + , TxtI "h$e" ||= jLam (\c -> (r1 |= c) <> enter s c) + ] + +-- carefully enter a closure that might be a thunk or a function + +-- ex may be a local var, but must've been copied to R1 before calling this +enter :: StgToJSConfig -> JExpr -> JStat +enter s ex = + jVar $ \c -> + mconcat [ jwhenS (app "typeof" [ex] .!==. jTyObject) returnStack + , c |= ex .^ "f" + , jwhenS (c .===. var "h$unbox_e") ((r1 |= ex .^ "d1") <> returnStack) + , SwitchStat (c .^ "t") + [ (toJExpr Con, mempty) + , (toJExpr Fun, mempty) + , (toJExpr Pap, returnStack) + , (toJExpr Blackhole, push' s [var "h$ap_0_0", ex, var "h$return"] + <> returnS (app "h$blockOnBlackhole" [ex])) + ] (returnS c) + ] + +updates :: StgToJSConfig -> JStat +updates s = + closure (ClosureInfo "h$upd_frame" (CIRegs 0 [PtrV]) "h$upd_frame" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (jVar $ \updatee waiters ss si sir -> + mconcat [ updatee |= stack .! (sp - 1) + , traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc") + , -- wake up threads blocked on blackhole + waiters |= updatee .^ "d2" + , jwhenS (waiters .!==. null_) + (loop 0 (.<. waiters .^ "length") + (\i -> appS "h$wakeupThread" [waiters .! i] <> postIncrS i)) + , -- update selectors + jwhenS ((app "typeof" [updatee .^ "m"] .===. jTyObject) .&&. (updatee .^ "m" .^ "sel")) + ((ss |= updatee .^ "m" .^ "sel") + <> loop 0 (.<. ss .^ "length") + (\i -> mconcat [ si |= ss .! i + , sir |= (si .^ "d2") `ApplExpr` [r1] + , ifS (app "typeof" [sir] .===. jTyObject) + (mconcat [ si .^ "f" |= sir .^ "f" + , si .^ "d1" |= sir .^ "d1" + , si .^ "d2" |= sir .^ "d2" + , si .^ "m" |= sir .^ "m" + ]) + (mconcat [ si .^ "f" |= var "h$unbox_e" + , si .^ "d1" |= sir + , si .^ "d2" |= null_ + , si .^ "m" |= 0 + ]) + , postIncrS i + ])) + , -- overwrite the object + ifS (app "typeof" [r1] .===. jTyObject) + (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((r1 .^ "f") .^ "n")) + , updatee .^ "f" |= r1 .^ "f" + , updatee .^ "d1" |= r1 .^ "d1" + , updatee .^ "d2" |= r1 .^ "d2" + , updatee .^ "m" |= r1 .^ "m" + , profStat s (updateCC updatee) + ]) + (mconcat [ updatee .^ "f" |= var "h$unbox_e" + , updatee .^ "d1" |= r1 + , updatee .^ "d2" |= null_ + , updatee .^ "m" |= 0 + , profStat s (updateCC updatee) + ]) + , adjSpN' 2 + , traceRts s (jString "h$upd_frame: updating: " + + updatee + + jString " -> " + + r1) + , returnStack + ]) + <> + closure (ClosureInfo "h$upd_frame_lne" (CIRegs 0 [PtrV]) "h$upd_frame_lne" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (jVar $ \updateePos -> + (updateePos |= stack .! (sp - 1)) + <> (stack .! updateePos |= r1) + <> adjSpN' 2 + <> traceRts s (jString "h$upd_frame_lne: updating: " + + updateePos + + jString " -> " + + r1) + <> returnStack) + where + updateCC updatee = updatee .^ "cc" |= jCurrentCCS + +selectors :: StgToJSConfig -> JStat +selectors s = + mkSel "1" (.^ "d1") + <> mkSel "2a" (.^ "d2") + <> mkSel "2b" (\x -> x .^ "d2" .^ "d1") + <> mconcat (map mkSelN [3..16]) + where + mkSelN :: Int -> JStat + mkSelN x = mkSel (pack $ show x) + (\e -> SelExpr (SelExpr (toJExpr e) (TxtI (pack "d2"))){-[je| `toJExpr`.d2 |]-} + (TxtI $ pack ("d" ++ show (x-1)))) + + + mkSel :: ShortText -> (JExpr -> JExpr) -> JStat + mkSel name sel = + mconcat [TxtI createName ||= jLam (\r -> traceRts s (toJExpr ("selector create: " <> name <> " for ") + (r .^ "alloc")) + <> ifS (isThunk r .||. isBlackhole r) + (returnS (app "h$mkSelThunk" [r, toJExpr (v entryName), toJExpr (v resName)])) + (returnS (sel r))) + , TxtI resName ||= jLam (\r -> traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc")) + <> returnS (sel r)) + , closure (ClosureInfo entryName (CIRegs 0 [PtrV]) ("select " <> name) (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar $ \tgt -> + (tgt |= r1 .^ "d1") + <> traceRts s (toJExpr ("selector entry: " <> name <> " for ") + (tgt .^ "alloc")) + <> ifS (isThunk tgt .||. isBlackhole tgt) + (preIncrS sp + <> (stack .! sp |= var frameName) + <> returnS (app "h$e" [tgt])) + (returnS (app "h$e" [sel tgt]))) + , closure + (ClosureInfo frameName (CIRegs 0 [PtrV]) ("select " <> name <> " frame") (CILayoutFixed 0 []) CIStackFrame mempty) + $ mconcat [ traceRts s (toJExpr ("selector frame: " <> name)) + , postDecrS sp + , returnS (app "h$e" [sel r1]) + ] + ] + + where + v x = JVar (TxtI x) + n ext = "h$c_sel_" <> name <> ext + createName = n "" + resName = n "_res" + entryName = n "_e" + frameName = n "_frame_e" + + +{- + Partial applications. There are two different kinds of partial application: + pap_r contains r registers, pap_gen can contain any number + + layout: + - d1 = function + - d2.d1 & 0xff = number of args + d2.d1 >> 8 = number of registers (r for h$pap_r) + - d2.d2.. = args (r) +-} +-- arity is the remaining arity after our supplied arguments are applied +mkPap :: StgToJSConfig + -> Ident -- ^ id of the pap object + -> JExpr -- ^ the function that's called (can be a second pap) + -> JExpr -- ^ number of arguments in pap + -> [JExpr] -- ^ values for the supplied arguments + -> JStat +mkPap s tgt fun n values = + traceRts s (toJExpr $ "making pap with: " ++ show (length values) ++ " items") + `mappend` + allocDynamic s True tgt (toJExpr entry) (fun:papAr:map toJExpr values') + (if csProf s then Just jCurrentCCS else Nothing) + where + papAr = funOrPapArity fun Nothing - toJExpr (length values * 256) - n + + values' | GHC.Prelude.null values = [null_] + | otherwise = values + entry | length values > numSpecPap = TxtI "h$pap_gen" + | otherwise = TxtI . pack $ "h$pap_" ++ show (length values) + +-- specialized (faster) pap generated for [0..numSpecPap] +-- others use h$pap_gen +specPap :: [Int] +specPap = [0..numSpecPap] + +numSpecPap :: Int +numSpecPap = 6 + +pap :: StgToJSConfig + -> Int + -> JStat +pap s r = closure (ClosureInfo funcName CIRegsUnknown funcName (CILayoutUnknown (r+2)) CIPap mempty) body + where + funcName = pack ("h$pap_" ++ show r) + + body = + jVar $ \c d f extra -> + mconcat [ c |= r1 .^ "d1" + , d |= r1 .^ "d2" + , f |= c .^ "f" + , assertRts s (isFun' f .||. isPap' f) (funcName <> ": expected function or pap") + , profStat s (enterCostCentreFun currentCCS) + , extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r + , traceRts s (toJExpr (funcName <> ": pap extra args moving: ") + extra) + , moveBy extra + , loadOwnArgs d + , r1 |= c + , returnS f + ] + moveBy extra = SwitchStat extra + (reverse $ map moveCase [1..maxReg-r-1]) mempty + moveCase m = (toJExpr m, toJExpr (intToJSReg (m+r+1)) |= toJExpr (intToJSReg (m+1))) + loadOwnArgs d = mconcat $ map (\r -> + toJExpr (intToJSReg (r+1)) |= dField d (r+2)) [1..r] + dField d n = SelExpr d (TxtI . pack $ ('d':show (n-1))) + +-- Construct a generic PAP +papGen :: StgToJSConfig -> JStat +papGen cfg = + closure (ClosureInfo funcName CIRegsUnknown funcName CILayoutVariable CIPap mempty) + (jVar $ \c f d pr or r -> + mconcat [ c |= r1 .^ "d1" + , f |= c .^ "f" + , d |= r1 .^ "d2" + , pr |= funOrPapArity c (Just f) .>>. 8 + , or |= papArity r1 .>>. 8 + , r |= pr - or + , assertRts cfg + (isFun' f .||. isPap' f) + (jString "h$pap_gen: expected function or pap") + , profStat cfg (enterCostCentreFun currentCCS) + , traceRts cfg (jString "h$pap_gen: generic pap extra args moving: " + or) + , appS "h$moveRegs2" [or, r] + , loadOwnArgs d r + , r1 |= c + , returnS f + ]) + + + where + funcName = "h$pap_gen" + loadOwnArgs d r = + let prop n = d .^ ("d" <> pack (show $ n+1)) + loadOwnArg n = (toJExpr n, toJExpr (intToJSReg (n+1)) |= prop n) + in SwitchStat r (map loadOwnArg [127,126..1]) mempty + +-- general utilities +-- move the first n registers, starting at R2, m places up (do not use with negative m) +-- FIXME (Jeff, 2022/03): pick a better name, e.g., `r2moveRegs` +moveRegs2 :: JStat +moveRegs2 = TxtI "h$moveRegs2" ||= jLam moveSwitch + where + moveSwitch n m = SwitchStat ((n .<<. 8) .|. m) switchCases (defaultCase n m) + -- fast cases + -- TODO: tune the parameteters for performance and size + switchCases = [switchCase n m | n <- [1..5], m <- [1..4]] + switchCase :: Int -> Int -> (JExpr, JStat) + switchCase n m = (toJExpr $ + (n `Bits.shiftL` 8) Bits..|. m + , mconcat (map (`moveRegFast` m) [n+1,n..2]) + <> BreakStat Nothing {-[j| break; |]-}) + moveRegFast n m = toJExpr (intToJSReg (n+m)) |= toJExpr (intToJSReg n) + -- fallback + defaultCase n m = + loop n (.>.0) (\i -> appS "h$setReg" [i+1+m, app "h$getReg" [i+1]] `mappend` postDecrS i) + + +-- Initalize a variable sized object from an array of values +initClosure :: StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr +initClosure cfg entry values ccs + | csProf cfg = + app "h$init_closure" [ toJExpr (jhFromList [ ("f" , entry) + , ("d1", null_) + , ("d2", null_) + , ("m" , 0) + , ("cc", ccs)]) + , values] + | otherwise = + app "h$init_closure" [ toJExpr (jhFromList [ ("f" , entry) + , ("d1", null_) + , ("d2", null_) + , ("m" , 0)]) + , values] + + +-- FIXME: where to put this +closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@ + -> JStat -- ^ rhs + -> JStat +closure ci body = (TxtI (ciVar ci)||= jLam body) `mappend` toStat ci + +-- FIXME: where to put this +conClosure :: ShortText -> ShortText -> CILayout -> Int -> JStat +conClosure symbol name layout constr = + closure (ClosureInfo symbol (CIRegs 0 [PtrV]) name layout (CICon constr) mempty) + (returnS (stack .! sp)) diff --git a/compiler/GHC/JS/Rts/Rts.hs b/compiler/GHC/JS/Rts/Rts.hs new file mode 100644 index 0000000000..b0ba541806 --- /dev/null +++ b/compiler/GHC/JS/Rts/Rts.hs @@ -0,0 +1,668 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -O0 #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Rts.Rts +-- 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> +-- Stability : experimental +-- +-- Top level driver of the JavaScript Backend RTS. This file is an +-- implementation of the JS RTS for the JS backend written as an EDSL in +-- Haskell. It assumes the existence of pre-generated JS functions, included as +-- js-sources... +-- +-- FIXME: Jeff (2022,03): Finish module description. Specifically: +-- 1. Since this is the top level module for the RTS, what is the architecture +-- of the RTS? How does it all hold together? Describe the memory layout, any +-- other tricks the RTS plays, and relevant sibling modules +-- +----------------------------------------------------------------------------- + +module GHC.JS.Rts.Rts where + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Heap +import GHC.StgToJS.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.Types +import GHC.JS.Rts.Apply + +import qualified GHC.Data.ShortText as T + +import Data.Array +import Data.Char (toLower, toUpper) +import qualified Data.Bits as Bits +import qualified Data.Map as M + +import Prelude + +----------------------------------------------------------------------------- +-- +-- Pre-generated RTS for the JS backend +-- +-- TODO: Jeff (2022,03): + +-- 1. There are numerous string literals sprinkled throughout the RTS, these +-- should be moved and isolated into a single module and then used throughout +-- the RTS and StgToJS Pipeline +-- +-- 2. The RTS makes a lot of use of the Monoid instances on lists since the +-- Haskell portion is essentially building a JavaScript AST for the JS Rts and +-- then pretty printing it so it can be used by the js backend. However, all +-- this merging on lists is going to be extremely inefficient. (++) is O(n^2) +-- and furthermore we have nested list structures. This implies a better data +-- structure with an emphasis on fast merging is likely to reduce compile times +-- for this RTS. +-- +-- 3. Similar to (2), most of the RTS is a function foo :: <something> with +-- definition foo [...<something>...] = mconcat ...<the body is JS land>... This +-- is fine, however it implies a monadic design for this EDSL might lead to more +-- readable code. Or in other words, `mconcat` and friends are just boiler +-- plate, and what we really have is a monadic EDSL where the monad is a kind of +-- Writer monad. Which we have essentially recreated here since bind in the +-- Writer monad is mapConcat and you'll notice that most of the functions in the +-- RTS do exactly that, i.e., apply a function which generates a list, then +-- concats. So we are dealing with a Writer monad but aren't using Haskell's +-- language facilities to be explicit about it. Hence all the boilerplate. Side +-- note, we might also consider two alternative approaches if we go with a +-- monadic design: +-- -- a. Continuation passing style so that intermediate lists fuse +-- -- b. A writer monad with a difference list, this would essentially be a +-- -- zipper but whether it is worth it or not depend on how often children need +-- -- to access their siblings, if they do that a lot then we'll have huge +-- -- speedups, if not then we likely won't gain anything + +----------------------------------------------------------------------------- + +garbageCollector :: JStat +garbageCollector = + mconcat [ TxtI "h$resetRegisters" ||= jLam (mconcat $ map resetRegister [minBound..maxBound]) + , TxtI "h$resetResultVars" ||= jLam (mconcat $ map resetResultVar [minBound..maxBound]) + ] + + +resetRegister :: StgReg -> JStat +resetRegister r = toJExpr r |= null_ + +resetResultVar :: StgRet -> JStat +resetResultVar r = toJExpr r |= null_ + +{- + use h$c1, h$c2, h$c3, ... h$c24 instead of making objects manually so layouts + and fields can be changed more easily + -} +closureConstructors :: StgToJSConfig -> JStat +closureConstructors s = + declClsConstr "h$c" ["f"] [var "f", null_, null_, 0] + <> declClsConstr "h$c0" ["f"] [var "f", null_, null_, 0] -- FIXME: same as h$c, maybe remove one of them? + <> declClsConstr "h$c1" ["f", "x1"] [var "f", var "x1", null_, 0] + <> declClsConstr "h$c2" ["f", "x1", "x2"] [var "f", var "x1", var "x2", 0] + <> mconcat (map mkClosureCon [3..24]) + <> mconcat (map mkDataFill [1..24]) + where + prof = csProf s + addCCArg as = map TxtI $ as ++ ["cc" | prof] + addCCArg' as = as ++ [TxtI "cc" | prof] + addCCField fs = jhFromList $ fs ++ [("cc", var "cc") | prof] + + declClsConstr i as fs = TxtI i ||= ValExpr (JFunc (addCCArg as) + ( jVar $ \x -> + mconcat [ checkC + , x |= toJExpr (addCCField $ zip ["f", "d1", "d2", "m"] fs) + , notifyAlloc x + , traceAlloc x + , returnS x + ] + )) + + traceAlloc x | csTraceRts s = appS "h$traceAlloc" [x] + | otherwise = mempty + + notifyAlloc x | csDebugAlloc s = appS "h$debugAlloc_notifyAlloc" [x] + | otherwise = mempty + + -- only JSVal can typically contain undefined or null + -- although it's possible (and legal) to make other Haskell types + -- to contain JS refs directly + -- this can cause false positives here + checkC :: JStat + checkC | csAssertRts s = + jVar $ \msg -> + jwhenS (var "arguments" .! 0 .!==. jString "h$ghcjszmprimZCGHCJSziPrimziJSVal_con_e") + (loop 1 (.<. var "arguments" .^ "length") + (\i -> + mconcat [msg |= jString "warning: undefined or null in argument: " + + i + + jString " allocating closure: " + (var "arguments" .! 0 .^ "n") + , appS "h$log" [msg] + , jwhenS (var "console" .&&. (var "console" .^ "trace")) ((var "console" .^ "trace") `ApplStat` [msg]) + , postIncrS i + ]) + + ) + | otherwise = mempty + + -- h$d is never used for JSVal (since it's only for constructors with + -- at least three fields, so we always warn here + checkD | csAssertRts s = + loop 0 (.<. var "arguments" .^ "length") + (\i -> jwhenS ((var "arguments" .! i .===. null_) + .||. (var "arguments" .! i .===. undefined_)) + (jVar $ \msg -> + mconcat [ msg |= jString "warning: undefined or null in argument: " + i + jString " allocating fields" + , jwhenS (var "console" .&&. (var "console" .^ "trace")) + ((var "console" .^ "trace") `ApplStat` [msg]) + ])) + + | otherwise = mempty + + mkClosureCon :: Int -> JStat + mkClosureCon n = let funName = TxtI $ T.pack ("h$c" ++ show n) + vals = TxtI "f" : addCCArg' (map (TxtI . T.pack . ('x':) . show) [(1::Int)..n]) + fun = JFunc vals funBod + funBod = + jVar $ \x -> + mconcat [ checkC + , x |= toJExpr (addCCField [("f", var "f"), ("d1", var "x1"), ("d2", toJExpr obj), ("m", 0)]) + , notifyAlloc x + , traceAlloc x + , returnS x + ] + + -- TODO: Jeff (2022,03): comment on the meaning of + -- [1..] and [2..n], I suppose this means that 0, and + -- 0,1,2 are reserved? + obj = JHash . M.fromList $ zip + (map (T.pack . ('d':) . show) [(1::Int)..]) + (map (toJExpr . TxtI . T.pack . ('x':) . show) [2..n]) + in funName ||= toJExpr fun + + mkDataFill :: Int -> JStat + mkDataFill n = let funName = TxtI $ T.pack ("h$d" ++ show n) + ds = map (T.pack . ('d':) . show) [(1::Int)..n] + obj = JHash . M.fromList . zip ds $ map (toJExpr . TxtI) ds + fun = JFunc (map TxtI ds) (checkD <> returnS (toJExpr obj)) + in funName ||= toJExpr fun + +stackManip :: JStat +stackManip = mconcat (map mkPush [1..32]) <> + mconcat (map mkPpush [1..255]) + where + mkPush :: Int -> JStat + mkPush n = let funName = TxtI $ T.pack ("h$p" ++ show n) + as = map (TxtI . T.pack . ('x':) . show) [1..n] + fun = JFunc as ((sp |= sp + toJExpr n) + <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) + [1..] as)) + in funName ||= toJExpr fun + + -- | partial pushes, based on bitmap, increases Sp by highest bit + mkPpush :: Integer -> JStat + mkPpush sig | sig Bits..&. (sig+1) == 0 = mempty -- already handled by h$p + mkPpush sig = let funName = TxtI $ T.pack ("h$pp" ++ show sig) + bits = bitsIdx sig + n = length bits + h = last bits + args = map (TxtI . T.pack . ('x':) . show) [1..n] + fun = JFunc args $ + mconcat [ sp |= sp + toJExpr (h+1) + , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) + ] + in funName ||= toJExpr fun + +bitsIdx :: Integer -> [Int] +bitsIdx n | n < 0 = error "bitsIdx: negative" + | otherwise = go n 0 + where + go 0 _ = [] + go m b | Bits.testBit m b = b : go (Bits.clearBit m b) (b+1) + | otherwise = go (Bits.clearBit m b) (b+1) + +bhLneStats :: StgToJSConfig -> JExpr -> JExpr -> JStat +bhLneStats _s p frameSize = + jVar $ \v -> + mconcat [ v |= stack .! p + , ifS v + ((sp |= sp - frameSize) + <> ifS (v .===. var "h$blackhole") + (returnS $ app "h$throw" [var "h$baseZCControlziExceptionziBasezinonTermination", false_]) + (mconcat [r1 |= v + , sp |= sp - frameSize + , returnStack + ])) + ((stack .! p |= var "h$blackhole") <> returnS null_) + ] + + +-- FIXME move somewhere else +declRegs :: JStat +-- FIXME prevent holes +declRegs = + mconcat [ TxtI "h$regs" ||= toJExpr (JList []) + , mconcat (map declReg (enumFromTo R1 R32)) + , regGettersSetters + , loadRegs + ] + where + declReg r = (decl . TxtI . T.pack . ("h$"++) . map toLower . show) r + <> BlockStat [AssignStat (toJExpr r) (ValExpr (JInt 0))] -- [j| `r` = 0; |] + +regGettersSetters :: JStat +regGettersSetters = + mconcat [ TxtI "h$getReg" ||= jLam (\n -> SwitchStat n getRegCases mempty) + , TxtI "h$setReg" ||= jLam (\n v -> SwitchStat n (setRegCases v) mempty) + ] + where + getRegCases = + map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) (enumFrom R1) + setRegCases v = + map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) (enumFrom R1) + +loadRegs :: JStat +loadRegs = mconcat $ map mkLoad [1..32] + where + mkLoad :: Int -> JStat + mkLoad n = let args = map (TxtI . T.pack . ("x"++) . show) [1..n] + assign = zipWith (\a r -> toJExpr r |= toJExpr a) + -- FIXME: Jeff (2022,03) the use of reverse, + -- take, and enumFrom here heavily implies + -- Data.Sequence would be a better data + -- structure to hold the regs. Or perhaps we + -- steal the indices from the registers array? + -- Either way we can avoid allocating this + -- intermediate `enumFrom R1` list + args (reverse $ take n (enumFrom R1)) + fname = TxtI $ T.pack ("h$l" ++ show n) + fun = JFunc args (mconcat assign) + in fname ||= toJExpr fun + +-- assign registers R1 ... Rn +-- assigns Rn first +assignRegs :: StgToJSConfig -> [JExpr] -> JStat +assignRegs _ [] = mempty +assignRegs s xs + | l <= 32 && not (csInlineLoadRegs s) + = ApplStat (ValExpr (JVar $ assignRegs'!l)) (reverse xs) + | otherwise = mconcat . reverse $ + zipWith (\r ex -> toJExpr r |= ex) (take l $ enumFrom R1) xs + where + l = length xs + +assignRegs' :: Array Int Ident +assignRegs' = listArray (1,32) (map (TxtI . T.pack . ("h$l"++) . show) [(1::Int)..32]) + +declRets :: JStat +declRets = mconcat $ map (decl . TxtI . T.pack . ("h$"++) . map toLower . show) (enumFrom Ret1) + +trace :: ToJExpr a => a -> JStat +trace ex = appS "h$log" [toJExpr ex] + +closureTypes :: JStat +closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> closureTypeName + where + mkClosureType :: ClosureType -> JStat + mkClosureType c = let s = TxtI . T.pack $ "h$" ++ map toUpper (show c) ++ "_CLOSURE" + in s ||= toJExpr c + closureTypeName :: JStat + closureTypeName = + TxtI "h$closureTypeName" ||= jLam (\c -> + mconcat (map (ifCT c) [minBound..maxBound]) + <> returnS (jString "InvalidClosureType")) + + ifCT :: JExpr -> ClosureType -> JStat + ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) + +rtsDecls :: JStat +rtsDecls = jsSaturate (Just "h$RTSD") $ + mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread + , TxtI "h$stack" ||= null_ -- stack for the current thread + , TxtI "h$sp" ||= 0 -- stack pointer for the current thread + , TxtI "h$initStatic" ||= toJExpr (JList []) -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs + , TxtI "h$staticThunks" ||= toJExpr (jhFromList []) -- funcName -> heapidx map for srefs + , TxtI "h$staticThunksArr" ||= toJExpr (JList []) -- indices of updatable thunks in static heap + -- stg registers + , declRegs + , declRets] + +rts :: StgToJSConfig -> JStat +rts = jsSaturate (Just "h$RTS") . rts' + +rts' :: StgToJSConfig -> JStat +rts' s = + mconcat [ closureConstructors s + , garbageCollector + , stackManip + -- settings (FIXME should be const) + , TxtI "h$rts_traceForeign" ||= toJExpr (csTraceForeign s) + , TxtI "h$rts_profiling" ||= toJExpr (csProf s) + -- closure types (FIXME should be const) + , TxtI "h$ct_fun" ||= toJExpr Fun + , TxtI "h$ct_con" ||= toJExpr Con + , TxtI "h$ct_thunk" ||= toJExpr Thunk + , TxtI "h$ct_pap" ||= toJExpr Pap + , TxtI "h$ct_blackhole" ||= toJExpr Blackhole + , TxtI "h$ct_stackframe" ||= toJExpr StackFrame + -- var / closure field types (FIXME should be const) + , TxtI "h$vt_ptr" ||= toJExpr PtrV + , TxtI "h$vt_void" ||= toJExpr VoidV + , TxtI "h$vt_double" ||= toJExpr IntV + , TxtI "h$vt_long" ||= toJExpr LongV + , TxtI "h$vt_addr" ||= toJExpr AddrV + , TxtI "h$vt_rtsobj" ||= toJExpr RtsObjV + , TxtI "h$vt_obj" ||= toJExpr ObjV + , TxtI "h$vt_arr" ||= toJExpr ArrV + , TxtI "h$bh" ||= jLam (bhStats s True) + , TxtI "h$bh_lne" ||= jLam (\x frameSize -> bhLneStats s x frameSize) + , closure (ClosureInfo "h$blackhole" (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty) + (appS "throw" [jString "oops: entered black hole"]) + , closure (ClosureInfo "h$blackholeTrap" (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty) + (appS "throw" [jString "oops: entered multiple times"]) + , closure (ClosureInfo "h$done" (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty) + (appS "h$finishThread" [var "h$currentThread"] <> returnS (var "h$reschedule")) + , closure (ClosureInfo "h$doneMain_e" (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty) + (returnS (var "h$doneMain")) + , conClosure "h$false_e" "GHC.Types.False" (CILayoutFixed 0 []) 1 + , conClosure "h$true_e" "GHC.Types.True" (CILayoutFixed 0 []) 2 + , conClosure "h$integerzmwiredzminZCGHCziIntegerziTypeziSzh_con_e" "GHC.Integer.Type.S#" (CILayoutFixed 1 [IntV]) 1 + , conClosure "h$integerzmwiredzminZCGHCziIntegerziTypeziJpzh_con_e" "GHC.Integer.Type.Jp#" (CILayoutFixed 1 [ObjV]) 2 + , conClosure "h$integerzmwiredzminZCGHCziIntegerziTypeziJnzh_con_e" "GHC.Integer.Type.Jn#" (CILayoutFixed 1 [ObjV]) 3 + -- generic data constructor with 1 non-heapobj field + , conClosure "h$data1_e" "data1" (CILayoutFixed 1 [ObjV]) 1 + -- generic data constructor with 2 non-heapobj fields + , conClosure "h$data2_e" "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1 + , closure (ClosureInfo "h$noop_e" (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty) + (returnS (stack .! sp)) + <> (TxtI "h$noop" ||= ApplExpr (var "h$c0") (var "h$noop_e" : [jSystemCCS | csProf s])) + , closure (ClosureInfo "h$catch_e" (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty) + (adjSpN' 3 <> returnS (stack .! sp)) + , closure (ClosureInfo "h$dataToTag_e" (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty) + $ mconcat [ r1 |= if_ (r1 .===. true_) 1 (if_ (typeof r1 .===. jTyObject) (r1 .^ "f" .^ "a" - 1) 0) + , adjSpN' 1 + , returnS (stack .! sp) + ] + -- function application to one argument + , closure (ClosureInfo "h$ap1_e" (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty) + (jVar $ \d1 d2 -> + mconcat [ d1 |= r1 .^ "d1" + , d2 |= r1 .^ "d2" + , appS "h$bh" [] + , profStat s enterCostCentreThunk + , r1 |= d1 + , r2 |= d2 + , returnS (app "h$ap_1_1_fast" []) + ]) + -- function application to two arguments + , closure (ClosureInfo "h$ap2_e" (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty) + (jVar $ \d1 d2 d3 -> + mconcat [ d1 |= r1 .^ "d1" + , d2 |= r1 .^ "d2" .^ "d1" + , d3 |= r1 .^ "d2" .^ "d2" + , appS "h$bh" [] + , profStat s enterCostCentreThunk + , r1 |= d1 + , r2 |= d2 + , r3 |= d3 + , returnS (app "h$ap_2_2_fast" []) + ]) + -- function application to three arguments + , closure (ClosureInfo "h$ap3_e" (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty) + (jVar $ \d1 d2 d3 d4 -> + mconcat [ d1 |= r1 .^ "d1" + , d2 |= r1 .^ "d2" .^ "d1" + , d3 |= r1 .^ "d2" .^ "d2" + , d4 |= r1 .^ "d2" .^ "d3" + , appS "h$bh" [] + , r1 |= d1 + , r2 |= d2 + , r3 |= d3 + , r4 |= d4 + , returnS (app "h$ap_3_3_fast" []) + ]) + -- select first field + , closure (ClosureInfo "h$select1_e" (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar $ \t -> + mconcat [ t |= r1 .^ "d1" + , adjSp' 3 + , stack .! (sp - 2) |= r1 + , stack .! (sp - 1) |= var "h$upd_frame" + , stack .! sp |= var "h$select1_ret" + , r1 .^ "f" |= var "h$blackhole" + , r1 .^ "d1" |= var "h$currentThread" + , r1 .^ "d2" |= null_ + , r1 |= t + , returnS (app "h$ap_0_0_fast" []) + ]) + , closure (ClosureInfo "h$select1_ret" (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty) + ((r1 |= r1 .^ "d1") + <> adjSpN' 1 + <> returnS (app "h$ap_0_0_fast" []) + ) + -- select second field of a two-field constructor + , closure (ClosureInfo "h$select2_e" (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar $ \t -> + mconcat [t |= r1 .^ "d1" + , adjSp' 3 + , stack .! (sp - 2) |= r1 + , stack .! (sp - 1) |= var "h$upd_frame" + , stack .! sp |= var "h$select2_ret" + , r1 .^ "f" |= var "h$blackhole" + , r1 .^ "d1" |= var "h$currentThread" + , r1 .^ "d2" |= null_ + , r1 |= t + , returnS (app "h$ap_0_0_fast" []) + ] + ) + , closure (ClosureInfo "h$select2_ret" (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty) + $ mconcat [ r1 |= r1 .^ "d2" + , adjSpN' 1 + , returnS (app "h$ap_0_0_fast" []) + ] + -- a thunk that just raises a synchronous exception + , closure (ClosureInfo "h$raise_e" (CIRegs 0 [PtrV]) "h$raise_e" (CILayoutFixed 0 []) CIThunk mempty) + (returnS (app "h$throw" [r1 .^ "d1", false_])) + , closure (ClosureInfo "h$raiseAsync_e" (CIRegs 0 [PtrV]) "h$raiseAsync_e" (CILayoutFixed 0 []) CIThunk mempty) + (returnS (app "h$throw" [r1 .^ "d1", true_])) + , closure (ClosureInfo "h$raiseAsync_frame" (CIRegs 0 []) "h$raiseAsync_frame" (CILayoutFixed 1 []) CIStackFrame mempty) + (jVar $ \ex -> + mconcat [ ex |= stack .! (sp - 1) + , adjSpN' 2 + , returnS (app "h$throw" [ex, true_]) + ]) + {- reduce result if it's a thunk, follow if it's an ind + add this to the stack if you want the outermost result + to always be reduced to whnf, and not an ind + -} + , closure (ClosureInfo "h$reduce" (CIRegs 0 [PtrV]) "h$reduce" (CILayoutFixed 0 []) CIStackFrame mempty) + (ifS (isThunk r1) + (returnS (r1 .^ "f")) + (adjSpN' 1 <> returnS (stack .! sp)) + ) + , rtsApply s + , closureTypes + , closure (ClosureInfo "h$runio_e" (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + $ mconcat [ r1 |= r1 .^ "d1" + , stack .! PreInc sp |= var "h$ap_1_0" + , returnS (var "h$ap_1_0") + ] + , closure (ClosureInfo "h$flushStdout_e" (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty) + $ mconcat [ r1 |= var "h$baseZCGHCziIOziHandlezihFlush" + , r2 |= var "h$baseZCGHCziIOziHandleziFDzistdout" + , returnS (app "h$ap_1_1_fast" []) + ] + , TxtI "h$flushStdout" ||= app "h$static_thunk" [var "h$flushStdout_e"] + -- the scheduler pushes this frame when suspending a thread that + -- has not called h$reschedule explicitly + , closure (ClosureInfo "h$restoreThread" (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty) + (jVar $ \f frameSize nregs -> + mconcat [f |= stack .! (sp - 2) + , frameSize |= stack .! (sp - 1) + , nregs |= frameSize - 3 + , loop 1 (.<=. nregs) + (\i -> appS "h$setReg" [i, stack .! (sp - 2 - i)] <> postIncrS i) + , sp |= sp - frameSize + , returnS f + ]) + -- return a closure in the stack frame to the next thing on the stack + , closure (ClosureInfo "h$return" (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + ((r1 |= stack .! (sp - 1)) + <> adjSpN' 2 + <> returnS (stack .! sp)) + -- return a function in the stack frame for the next call + , closure (ClosureInfo "h$returnf" (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (jVar $ \r -> + mconcat [ r |= stack .! (sp - 1) + , adjSpN' 2 + , returnS r + ]) + -- return this function when the scheduler needs to come into action + -- (yield, delay etc), returning thread needs to push all relevant + -- registers to stack frame, thread will be resumed by calling the stack top + , closure (ClosureInfo "h$reschedule" (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty) + (returnS $ var "h$reschedule") + -- debug thing, insert on stack to dump current result, should be boxed + , closure (ClosureInfo "h$dumpRes" (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty) + (jVar $ \re -> + mconcat [ appS "h$log" [jString "h$dumpRes result: " + stack .! (sp-1)] + , appS "h$log" [r1] + , appS "h$log" [app "h$collectProps" [r1]] + , jwhenS ((r1 .^ "f") .&&. (r1 .^ "f" .^ "n")) + (appS "h$log" [jString "name: " + r1 .^ "f" .^ "n"]) + , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString "d1"]) + (appS "h$log" [jString "d1: " + r1 .^ "d1"]) + , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString "d2"]) + (appS "h$log" [jString "d2: " + r1 .^ "d2"]) + , jwhenS (r1 .^ "f") $ mconcat + [ re |= New (app "RegExp" [jString "([^\\n]+)\\n(.|\\n)*"]) + , appS "h$log" [jString "function" + + ApplExpr (ApplExpr ((jString "" + r1 .^ "f") .^ "substring") [0, 50] .^ "replace") [r1, jString "$1"]] + ] + , adjSpN' 2 + , r1 |= null_ + , returnS (stack .! sp) + ]) + , closure (ClosureInfo "h$resume_e" (CIRegs 0 [PtrV]) "resume" (CILayoutFixed 0 []) CIThunk mempty) + (jVar $ \ss -> + mconcat [ss |= r1 .^ "d1" + , updateThunk' s + , loop 0 (.<. ss .^ "length") (\i -> (stack .! (sp+1+i) |= ss .! i) + <> postIncrS i) + , sp |= sp + ss .^ "length" + , r1 |= null_ + , returnS (stack .! sp) + ]) + , closure (ClosureInfo "h$unmaskFrame" (CIRegs 0 [PtrV]) "unmask" (CILayoutFixed 0 []) CIStackFrame mempty) + ((var "h$currentThread" .^ "mask" |= 0) + <> adjSpN' 1 + -- back to scheduler to give us async exception if pending + <> ifS (var "h$currentThread" .^ "excep" .^ "length" .>. 0) + (push' s [r1, var "h$return"] <> returnS (var "h$reschedule")) + (returnS (stack .! sp))) + , closure (ClosureInfo "h$maskFrame" (CIRegs 0 [PtrV]) "mask" (CILayoutFixed 0 []) CIStackFrame mempty) + ((var "h$currentThread" .^ "mask" |= 2) + <> adjSpN' 1 + <> returnS (stack .! sp)) + , closure (ClosureInfo "h$maskUnintFrame" (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty) + ((var "h$currentThread" .^ "mask" |= 1) + <> adjSpN' 1 + <> returnS (stack .! sp)) + , closure (ClosureInfo "h$unboxFFIResult" (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty) + (jVar $ \d -> + mconcat [d |= r1 .^ "d1" + , loop 0 (.<. d .^ "length") (\i -> appS "h$setReg" [i + 1, d .! i] <> postIncrS i) + , adjSpN' 1 + , returnS (stack .! sp) + ]) + , closure (ClosureInfo "h$unbox_e" (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty) + ((r1 |= r1 .^ "d1") <> returnS (stack .! sp)) + , closure (ClosureInfo "h$retryInterrupted" (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (jVar $ \a -> + mconcat [ a |= stack .! (sp - 1) + , adjSpN' 2 + , returnS (ApplExpr (a .! 0 .^ "apply") [var "this", ApplExpr (a .^ "slice") [1]]) + ]) + , closure (ClosureInfo "h$atomically_e" (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (ifS (app "h$stmValidateTransaction" []) + (appS "h$stmCommitTransaction" [] + <> adjSpN' 2 + <> returnS (stack .! sp)) + (push' s [var "h$checkInvariants_e"] + <> returnS (app "h$stmStartTransaction" [stack .! (sp - 2)]))) + , closure (ClosureInfo "h$checkInvariants_e" (CIRegs 0 [PtrV]) "check transaction invariants" (CILayoutFixed 0 []) CIStackFrame mempty) + (adjSpN' 1 + <> returnS (app "h$stmCheckInvariants" [])) + , closure (ClosureInfo "h$stmCheckInvariantStart_e" (CIRegs 0 []) "start checking invariant" (CILayoutFixed 2 [ObjV, RtsObjV]) CIStackFrame mempty) + (jVar $ \t inv m t1 -> + mconcat [ t |= stack .! (sp - 2) + , inv |= stack .! (sp - 1) + , m |= var "h$currentThread" .^ "mask" + , adjSpN' 3 + , t1 |= UOpExpr NewOp (app "h$Transaction" [inv .^ "action", t]) + , t1 .^ "checkRead" |= UOpExpr NewOp (app "h$Set" []) + , var "h$currentTread" .^ "transaction" |= t1 + , push' s [t1, m, var "h$stmInvariantViolatedHandler", var "h$catchStm_e"] + , r1 |= inv .^ "action" + , returnS (app "h$ap_1_0_fast" []) + ]) + , closure (ClosureInfo "h$stmCheckInvariantResult_e" (CIRegs 0 [PtrV]) "finish checking invariant" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (jVar $ \inv -> + mconcat [ inv |= stack .! (sp -1) + , adjSpN' 2 + , appS "h$stmUpdateInvariantDependencies" [inv] + , appS "h$stmAbortTransaction" [] + , returnS (stack .! sp) + ]) + + -- update invariant TVar dependencies and rethrow exception + -- handler must be pushed above h$stmCheckInvariantResult_e frame + , closure (ClosureInfo "h$stmInvariantViolatedHandler_e" (CIRegs 0 [PtrV]) "finish checking invariant" (CILayoutFixed 0 []) (CIFun 2 1) mempty) + (jVar $ \inv -> + mconcat [ jwhenS (stack .! sp .===. var "h$stmCheckInvariantResult_e") + (appS "throw" [jString "h$stmInvariantViolatedHandler_e: unexpected value on stack"]) + , inv |= stack .! (sp - 2) + , adjSpN' 2 + , appS "h$stmUpdateInvariantDependencies" [] + , appS "h$stmAbortTransaction" [] + , returnS (app "h$throw" [r2, false_]) + ]) + , TxtI "h$stmInvariantViolatedHandler" ||= app "h$c" (var "h$stmInvariantViolatedHandler_e" : [jSystemCCS | csProf s]) + , closure (ClosureInfo "h$stmCatchRetry_e" (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (adjSpN' 2 + <> appS "h$stmCommitTransaction" [] + <> returnS (stack .! sp)) + , closure (ClosureInfo "h$catchStm_e" (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty) + (adjSpN' 4 <> returnS (stack .! sp)) + , closure (ClosureInfo "h$stmResumeRetry_e" (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty) + (jVar $ \blocked -> + mconcat [ jwhenS (stack .! (sp - 2) .!==. var "h$atomically_e") + (appS "throw" [jString "h$stmResumeRetry_e: unexpected value on stack"]) + , blocked |= stack .! (sp - 1) + , adjSpN' 2 + , push' s [var "h$checkInvariants_e"] + , appS "h$stmRemoveBlockedThread" [blocked, var "h$currentThread"] + , returnS (app "h$stmStartTransaction" [stack .! (sp - 2)]) + ]) + , closure (ClosureInfo "h$lazy_e" (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty) + (jVar $ \x -> + mconcat [x |= ApplExpr (r1 .^ "d1") [] + , appS "h$bh" [] + , profStat s enterCostCentreThunk + , r1 |= x + , returnS (stack .! sp) + ]) + -- Top-level statements to generate only in profiling mode + , profStat s (closure (ClosureInfo "h$setCcs_e" (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (appS "h$restoreCCS" [ stack .! (sp - 1)] + <> adjSpN' 2 + <> returnS (stack .! sp))) + ] diff --git a/compiler/GHC/JS/Rts/Types.hs b/compiler/GHC/JS/Rts/Types.hs new file mode 100644 index 0000000000..68c42b0ea9 --- /dev/null +++ b/compiler/GHC/JS/Rts/Types.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE CPP, + FlexibleInstances, + OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Rts.Apply +-- 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> +-- Stability : experimental +-- +-- Types and utility functions used in the JS RTS. +-- FIXME: Jeff (2022,03): Add more details +----------------------------------------------------------------------------- + +module GHC.JS.Rts.Types where + +import GHC.JS.Make +import GHC.JS.Syntax +import GHC.StgToJS.Regs +import GHC.StgToJS.Types + +import GHC.Utils.Monad.State.Strict +import qualified GHC.Data.ShortText as T + +import GHC.Prelude + + +traceRts :: StgToJSConfig -> JExpr -> JStat +traceRts s ex = jStatIf (csTraceRts s) (appS "h$log" [ex]) + +assertRts :: ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat +assertRts s ex m = jStatIf (csAssertRts s) + (jwhenS (UOpExpr NotOp ex) (appS "throw" [toJExpr m])) + +jStatIf :: Bool -> JStat -> JStat +jStatIf True s = s +jStatIf _ _ = mempty + +clName :: JExpr -> JExpr +clName c = c .^ "n" + +clTypeName :: JExpr -> JExpr +clTypeName c = app "h$closureTypeName" [c .^ "t"] + +type C = State GenState JStat + +assertRtsStat :: C -> C +assertRtsStat stat = do + s <- gets gsSettings + if csAssertRts s then stat else return mempty + +-- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) +stackFrameSize :: JExpr -- ^ assign frame size to this + -> JExpr -- ^ stack frame header function + -> JStat -- ^ size of the frame, including header +stackFrameSize tgt f = + ifS (f .===. var "h$ap_gen") -- h$ap_gen is special + (tgt |= (stack .! (sp - 1) .>>. 8) + 2) -- special case, FIXME (Jeff, 2022/03): what and why is + -- it special and how does its + -- special-ness change this code + (jVar (\tag -> + mconcat + [tag |= f .^ "size" + , ifS (tag .<. 0) -- if tag is less than 0 + (tgt |= stack .! (sp - 1)) -- set target to stack pointer - 1 + (tgt |= mask8 tag + 1) -- else set to mask'd tag + 1 + ] + )) + +-- some utilities do do something with a range of regs +-- start or end possibly supplied as javascript expr +withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat +withRegs start end f = mconcat $ map f [start..end] + +withRegs' :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat +withRegs' start end = withRegs start end + +-- start from js expr, start is guaranteed to be at least min +-- from low to high (fallthrough!) +withRegsS :: JExpr -> StgReg -> StgReg -> Bool -> (StgReg -> JStat) -> JStat +withRegsS start min end fallthrough f = + SwitchStat start (map mkCase [min..end]) mempty + where + brk | fallthrough = mempty + | otherwise = BreakStat Nothing + mkCase r = let stat = f r + in (toJExpr r, mconcat [stat , stat , brk]) + +-- end from js expr, from high to low +withRegsRE :: StgReg -> JExpr -> StgReg -> Bool -> (StgReg -> JStat) -> JStat +withRegsRE start end max fallthrough f = + SwitchStat end (reverse $ map mkCase [start..max]) mempty + where + brk | fallthrough = mempty + | otherwise = BreakStat Nothing + mkCase r = (toJExpr (fromEnum r), mconcat [f r , brk]) + +jsVar :: String -> JExpr +jsVar = ValExpr . JVar . TxtI . T.pack diff --git a/compiler/GHC/JS/Syntax.hs b/compiler/GHC/JS/Syntax.hs index 79f53f39ee..ec7e1feb35 100644 --- a/compiler/GHC/JS/Syntax.hs +++ b/compiler/GHC/JS/Syntax.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -9,7 +8,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE PatternSynonyms #-} @@ -70,6 +68,12 @@ import qualified GHC.Data.ShortText as ST import GHC.Data.ShortText (ShortText) import GHC.Utils.Monad.State.Strict +-- FIXME: Jeff (2022,03): This state monad is strict, but uses a lazy list as +-- the state, since the strict state monad evaluates to WHNF, this state monad +-- will only evaluate to the first cons cell, i.e., we will be spine strict but +-- store possible huge thunks. This isn't a problem as long as we use this list +-- as a stack, but if we don't then any kind of Functor or Traverse operation +-- over this state will become yield a lot of thunks. newtype IdentSupply a = IS {runIdentSupply :: State [Ident] a} deriving Typeable @@ -100,7 +104,11 @@ instance Show a => Show (IdentSupply a) where show x = "(" ++ show (pseudoSaturate x) ++ ")" --- | Statements +-------------------------------------------------------------------------------- +-- Statements +-------------------------------------------------------------------------------- +-- FIXME (Jeff, 2022/03): statements according to what version of the standard? +-- | JavaScript statements data JStat = DeclStat Ident | ReturnStat JExpr @@ -141,7 +149,13 @@ appendJStat mx my = case (mx,my) of --- TODO: annotate expressions with type +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- +-- FIXME (Jeff, 2022/03): Expressions according to what version of the standard? +-- FIXME: annotate expressions with type. This is an EDSL of JS ASTs in Haskell. +-- There are many approaches to leveraging the GHCs type system for correctness +-- guarentees in EDSLs and we should use them -- | Expressions data JExpr = ValExpr JVal @@ -213,6 +227,9 @@ pattern Int x = ValExpr (JInt x) pattern String :: ShortText -> JExpr pattern String x = ValExpr (JStr x) +-------------------------------------------------------------------------------- +-- Values +-------------------------------------------------------------------------------- -- | Values data JVal = JVar Ident @@ -231,6 +248,9 @@ instance Outputable JVal where instance NFData JVal +-------------------------------------------------------------------------------- +-- Operators +-------------------------------------------------------------------------------- data JOp = EqOp -- == | StrictEqOp -- === @@ -294,6 +314,12 @@ instance Ord SaneDouble where instance Show SaneDouble where show (SaneDouble x) = show x +-------------------------------------------------------------------------------- +-- Identifiers +-------------------------------------------------------------------------------- +-- We use ShortText for identifier in JS backend + -- | Identifiers newtype Ident = TxtI { itxt:: ShortText} deriving (Show, Typeable, Ord, Eq, Generic, NFData) + diff --git a/compiler/GHC/StgToJS/CoreUtils.hs b/compiler/GHC/StgToJS/CoreUtils.hs index b945024c1b..e039483a12 100644 --- a/compiler/GHC/StgToJS/CoreUtils.hs +++ b/compiler/GHC/StgToJS/CoreUtils.hs @@ -1,11 +1,23 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- only for ToStat ClosureInfo + +-- FIXME: Jeff (2022,03): fix this orphan instance. the problem is that the +-- toStat ClosureInfo requires the helper function @closureInfoStat@ which in +-- turn requires numerous helper functions that are in this file. Thus, if we +-- moved this instance to StgToJS.Types then we'll create a module import cycle. + -- | Core utils module GHC.StgToJS.CoreUtils where import GHC.Prelude +import GHC.JS.Make import GHC.JS.Syntax + import GHC.StgToJS.Types import GHC.Stg.Syntax @@ -28,6 +40,9 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import qualified Data.Bits as Bits +import GHC.Data.ShortText + -- | can we unbox C x to x, only if x is represented as a Number isUnboxableCon :: DataCon -> Bool isUnboxableCon dc @@ -246,5 +261,83 @@ alignPrimReps (r:rs) vs = case (primRepSize r,vs) of alignIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])] alignIdPrimReps i = alignPrimReps (idPrimReps i) + alignIdExprs :: Id -> [JExpr] -> [TypedExpr] alignIdExprs i es = fmap (uncurry TypedExpr) (alignIdPrimReps i es) + +closureInfoStat :: Bool -> ClosureInfo -> JStat +closureInfoStat debug (ClosureInfo obj rs name layout CIThunk srefs) = + setObjInfoL debug obj rs layout Thunk name 0 srefs +closureInfoStat debug (ClosureInfo obj rs name layout (CIFun arity nregs) srefs) = + setObjInfoL debug obj rs layout Fun name (mkArityTag arity nregs) srefs +closureInfoStat debug (ClosureInfo obj rs name layout (CICon con) srefs) = + setObjInfoL debug obj rs layout Con name con srefs +closureInfoStat debug (ClosureInfo obj rs name layout CIBlackhole srefs) = + setObjInfoL debug obj rs layout Blackhole name 0 srefs +closureInfoStat debug (ClosureInfo obj rs name layout CIPap srefs) = + setObjInfoL debug obj rs layout Pap name 0 srefs +closureInfoStat debug (ClosureInfo obj rs name layout CIStackFrame srefs) = + setObjInfoL debug obj rs layout StackFrame name 0 srefs + +setObjInfoL :: Bool -- ^ debug: output symbol names + -> ShortText -- ^ the object name + -> CIRegs -- ^ things in registers + -> CILayout -- ^ layout of the object + -> ClosureType -- ^ closure type + -> ShortText -- ^ object name, for printing + -> Int -- ^ `a' argument, depends on type (arity, conid) + -> CIStatic -- ^ static refs + -> JStat +setObjInfoL debug obj rs CILayoutVariable t n a = + setObjInfo debug obj t n [] a (-1) rs +setObjInfoL debug obj rs (CILayoutUnknown size) t n a = + setObjInfo debug obj t n xs a size rs + where + xs = toTypeList (replicate size ObjV) +setObjInfoL debug obj rs (CILayoutFixed size layout) t n a = + setObjInfo debug obj t n xs a size rs + where + xs = toTypeList layout + +setObjInfo :: Bool -- ^ debug: output all symbol names + -> ShortText -- ^ the thing to modify + -> ClosureType -- ^ closure type + -> ShortText -- ^ object name, for printing + -> [Int] -- ^ list of item types in the object, if known (free variables, datacon fields) + -> Int -- ^ extra 'a' parameter, for constructor tag or arity + -> Int -- ^ object size, -1 (number of vars) for unknown + -> CIRegs -- ^ things in registers [VarType] -- ^ things in registers + -> CIStatic -- ^ static refs + -> JStat +setObjInfo debug obj t name fields a size regs static + | debug = appS "h$setObjInfo" [ var obj + , toJExpr t + , toJExpr name + , toJExpr fields + , toJExpr a + , toJExpr size + , toJExpr (regTag regs) + , toJExpr static + ] -- error "setObjInfo1" -- [j| h$setObjInfo(`TxtI obj`, `t`, `name`, `fields`, `a`, `size`, `regTag regs`, `static`); |] + | otherwise = appS "h$o" [ var obj + , toJExpr t + , toJExpr a + , toJExpr size + , toJExpr (regTag regs) + , toJExpr static + ] -- error "setObjInfo2" -- [j| h$o(`TxtI obj`,`t`,`a`,`size`,`regTag regs`,`static`); |] + where + regTag CIRegsUnknown = -1 + regTag (CIRegs skip types) = + let nregs = sum $ map varSize types + in skip + (nregs `Bits.shiftL` 8) + +-- | note: the statements only work after all top-level objects have been created +instance ToStat ClosureInfo where + toStat = closureInfoStat False + +mkArityTag :: Int -> Int -> Int +mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8) + +toTypeList :: [VarType] -> [Int] +toTypeList = concatMap (\x -> replicate (varSize x) (fromEnum x)) diff --git a/compiler/GHC/StgToJS/DataCon.hs b/compiler/GHC/StgToJS/DataCon.hs index 01e15bbfae..e68b22605b 100644 --- a/compiler/GHC/StgToJS/DataCon.hs +++ b/compiler/GHC/StgToJS/DataCon.hs @@ -6,6 +6,7 @@ module GHC.StgToJS.DataCon , allocCon , allocUnboxedCon , allocDynamicE + , allocDynamic ) where diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs index 28e2706734..7fa30866f7 100644 --- a/compiler/GHC/StgToJS/Expr.hs +++ b/compiler/GHC/StgToJS/Expr.hs @@ -68,6 +68,7 @@ import qualified Data.List as L import qualified Data.Set as S import qualified Data.Map as M import Control.Monad +import Control.Arrow ((&&&)) genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult) genExpr ctx stg = case stg of @@ -169,7 +170,7 @@ genBindLne :: HasDebugCallStack genBindLne ctx bndr = do vis <- map (\(x,y,_) -> (x,y)) <$> optimizeFree oldFrameSize (newLvs++map fst updBinds) - declUpds <- mconcat <$> mapM (fmap (\x -> x ||= null_) . jsIdI . fst) updBinds + declUpds <- mconcat <$> mapM (fmap (||= null_) . jsIdI . fst) updBinds let newFrameSize = oldFrameSize + length vis ctx' = ctx { ctxLne = addListToUniqSet (ctxLne ctx) bound @@ -181,8 +182,8 @@ genBindLne ctx bndr = do where oldFrame = ctxLneFrame ctx oldFrameSize = length oldFrame - isOldLv i = i `elementOfUniqSet` (ctxLne ctx) || - i `elem` (map fst oldFrame) + isOldLv i = i `elementOfUniqSet` ctxLne ctx || + i `elem` map fst oldFrame live = liveVars $ mkDVarSet $ stgLneLive' bndr newLvs = filter (not . isOldLv) (dVarSetElems live) binds = case bndr of @@ -210,7 +211,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) = myOffset = maybe (panic "genEntryLne: updatable binder not found in let-no-escape frame") ((payloadSize-) . fst) - (listToMaybe $ filter ((==i).fst.snd) (zip [0..] frame)) + (L.find ((==i) . fst . snd) (zip [0..] frame)) bh | isUpdatable update = jVar (\x -> mconcat [ x |= ApplExpr (var "h$bh_lne") [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)] @@ -244,7 +245,7 @@ genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do -- generate the entry function for a local closure genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () -genEntry _ _i (StgRhsCon {}) = return () -- mempty -- error "local data entry" +genEntry _ _i StgRhsCon {} = return () -- mempty -- error "local data entry" genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body) = resetSlots $ do let live = stgLneLiveExpr rhs -- error "fixme" -- probably find live vars in body ll <- loadLiveFun live @@ -544,7 +545,7 @@ genRet ctx e at as l = withNewIdent f lneLive = maximum $ 0 : map (fromMaybe 0 . lookupUFM (ctxLneFrameBs ctx)) allRefs ctx' = adjustCtxStack lneLive ctx lneVars = map fst $ take lneLive (ctxLneFrame ctx) - isLne i = i `elem` lneVars || i `elementOfUniqSet` (ctxLne ctx) + isLne i = i `elem` lneVars || i `elementOfUniqSet` ctxLne ctx nonLne = filter (not . isLne) (dVarSetElems l) f :: Ident -> G JStat @@ -562,8 +563,7 @@ genRet ctx e at as l = withNewIdent f ri (fixedLayout . reverse $ map (stackSlotType . fst3) free - ++ if prof then [ObjV] else [] - ++ map stackSlotType lneVars) + ++ if prof then [ObjV] else map stackSlotType lneVars) CIStackFrame sr emitToplevel $ r ||= toJExpr (JFunc [] fun') @@ -600,7 +600,7 @@ genAlts ctx e at me alts = do (st, er) <- case at of PolyAlt -> case alts of - [alt] -> (\b -> (branch_stat b, branch_result b)) <$> mkAlgBranch ctx e alt + [alt] -> (branch_stat &&& branch_result) <$> mkAlgBranch ctx e alt _ -> panic "genAlts: multiple polyalt" PrimAlt _tc @@ -885,24 +885,28 @@ allocDynAll haveDecl middle cls = do middle' = fromMaybe mempty middle makeObjs :: G JStat - makeObjs = do + makeObjs = fmap mconcat $ forM cls $ \(i,f,_,cc) -> do - ccs <- maybeToList <$> costCentreStackLbl cc - pure $ mconcat - [ dec i - , toJExpr i |= if csInlineAlloc settings - then ValExpr (jhFromList $ [ (closureEntry_ , f) - , (closureExtra1_, null_) - , (closureExtra2_, null_) - , (closureMeta_ , zero_) - ] - ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs) - else ApplExpr (var "h$c") (f : fmap (\cid -> ValExpr (JVar cid)) ccs) - ] + ccs <- maybeToList <$> costCentreStackLbl cc + pure $ mconcat + [ dec i + , toJExpr i |= if csInlineAlloc settings + then ValExpr (jhFromList $ [ (closureEntry_ , f) + , (closureExtra1_, null_) + , (closureExtra2_, null_) + , (closureMeta_ , zero_) + ] + ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs) + else ApplExpr (var "h$c") (f : fmap (ValExpr . JVar) ccs) + ] fillObjs = mconcat $ map fillObj cls fillObj (i,_,es,_) - | csInlineAlloc settings || length es > 24 = + | csInlineAlloc settings || length es > 24 = -- FIXME (Jeff, 2022/03): the call to length means `es` + -- should be something other than + -- a list. Also why is 24 + -- important? And 24 should be a + -- constant such as `fooThreshold` case es of [] -> mempty [ex] -> toJExpr i .^ closureExtra1_ |= toJExpr ex @@ -931,7 +935,8 @@ allocDynAll haveDecl middle cls = do dec i | haveDecl = DeclStat i | otherwise = mempty - checkObjs | csAssertRts settings = mconcat $ map (\(i,_,_,_) -> (ApplStat (ValExpr (JVar (TxtI "h$checkObj")))) (((:) (toJExpr i)) []){-[j| h$checkObj(`i`); |]-}) cls + checkObjs | csAssertRts settings = mconcat $ + map (\(i,_,_,_) -> ApplStat (ValExpr (JVar (TxtI "h$checkObj"))) [toJExpr i] {-[j| h$checkObj(`i`); |]-}) cls | otherwise = mempty objs <- makeObjs diff --git a/compiler/GHC/StgToJS/Heap.hs b/compiler/GHC/StgToJS/Heap.hs index 0edfe6729e..95d43994b9 100644 --- a/compiler/GHC/StgToJS/Heap.hs +++ b/compiler/GHC/StgToJS/Heap.hs @@ -26,6 +26,8 @@ module GHC.StgToJS.Heap , closureMeta_ , closureExtra1_ , closureExtra2_ + -- * Javascript Type literals + , jTyObject ) where @@ -36,6 +38,87 @@ import GHC.JS.Make import GHC.StgToJS.Types import GHC.Data.ShortText (ShortText) +-- Note [JS heap objects] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- +-- TODO: add more details from https://www.haskell.org/haskell-symposium/2013/ghcjs.pdf +-- +-- Objects on the heap ("closures") are represented as JavaScript objects with +-- the following fields: +-- +-- { f: function -- entry function +-- , m: meta -- meta data +-- , d1: x -- closure specific fields +-- , d2: y +-- } +-- +-- The object returned when entering heap objects (closure.f) has the following +-- fields: +-- +-- { t: closure type +-- , a: constructor tag / fun arity +-- } +-- +-- THUNK = +-- { f = returns the object reduced to WHNF +-- , m = ? +-- , d1 = ? +-- , d2 = ? +-- } +-- +-- FUN = +-- { f = function itself +-- , m = ? +-- , d1 = free variable 1 +-- , d2 = free variable 2 +-- } +-- +-- PAP = +-- { f = ? +-- , m = ? +-- , d1 = ? +-- , d2 = +-- { d1 = PAP arity +-- } +-- } +-- +-- CON = +-- { f = entry function of the datacon worker +-- , m = 0 +-- , d1 = first arg +-- , d2 = arity = 2: second arg +-- arity > 2: { d1, d2, ...} object with remaining args (starts with "d1 = x2"!) +-- } +-- +-- BLACKHOLE = +-- { f = h$blackhole +-- , m = ? +-- , d1 = owning TSO +-- , d2 = waiters array +-- } +-- +-- STACKFRAME = +-- { f = ? +-- , m = ? +-- , d1 = ? +-- , d2 = ? +-- } + +-- FIXME: Jeff (2022,03): These helpers are a classic case of using a newtype +-- over a type synonym to leverage GHC's type checker. Basically we never want +-- to mix these up, and so we should have: +-------------------------------------- +-- newtype ClosureEntry = ClosureEntry { unClosureEntry :: ShortText } +-- newtype ClosureExtra1 = ClosureExtra1 { unClosureExtra1 :: ShortText } +-- newtype ClosureExtra2 = ClosureExtra2 { unClosureExtra2 :: ShortText } +-- newtype ClosureMeta = ClosureMeta { unClosureMeta :: ShortText } +-------------------------------------- +-- especially since any bugs which result from confusing these will be catastrophic and hard to debug +-- also NOTE: if ClosureExtra<N> is truly unbounded then we should have: +-- newtype ClosureExtras = ClosureExtras { unClosureExtras :: [ShortText] } +-- or use an Array and amortize increasing the arrays size when needed; depending +-- on its use case in the RTS of course + closureEntry_ :: ShortText closureEntry_ = "f" @@ -57,7 +140,8 @@ entryConTag_ = "a" entryFunArity_ :: ShortText entryFunArity_ = "a" - +jTyObject :: JExpr +jTyObject = jString "object" closureType :: JExpr -> JExpr closureType = entryClosureType . entry diff --git a/compiler/GHC/StgToJS/Monad.hs b/compiler/GHC/StgToJS/Monad.hs index 275aab9dab..982a1846c1 100644 --- a/compiler/GHC/StgToJS/Monad.hs +++ b/compiler/GHC/StgToJS/Monad.hs @@ -14,6 +14,7 @@ module GHC.StgToJS.Monad , updateThunk , updateThunk' , liftToGlobal + , bhStats -- * IDs , withNewIdent , makeIdent @@ -23,6 +24,7 @@ module GHC.StgToJS.Monad , jsIdN , jsIdI , jsIdIN + , jsIdIdent' , jsIdV , jsEnId , jsEnIdI @@ -55,6 +57,7 @@ module GHC.StgToJS.Monad , push' , adjSpN , adjSpN' + , adjSp' , adjSp , pushNN , pushNN' @@ -219,6 +222,25 @@ jsIdIN i n = jsIdIdent i (Just n) IdPlain jsIdN :: Id -> Int -> G JExpr jsIdN i n = ValExpr . JVar <$> jsIdIdent i (Just n) IdPlain +-- uncached +jsIdIdent' :: Id -> Maybe Int -> IdType -> G Ident +jsIdIdent' i mn suffix0 = do + (prefix, u) <- mkPrefixU + let i' = (\x -> ST.pack $ "h$"++prefix++x++mns++suffix++u) . zEncodeString $ name + i' `seq` return (TxtI i') + where + suffix = idTypeSuffix suffix0 + mns = maybe "" (('_':).show) mn + name = ('.':) . nameStableString . localiseName . getName $ i + + mkPrefixU :: G (String, String) + mkPrefixU + | isExportedId i, Just x <- (nameModule_maybe . getName) i = do + let xstr = unitModuleString x + return (zEncodeString xstr, "") + | otherwise = (,('_':) . encodeUnique . getKey . getUnique $ i) . ('$':) + . zEncodeString . unitModuleString <$> State.gets gsModule + -- entry id jsEnId :: Id -> G JExpr jsEnId i = ValExpr . JVar <$> jsEnIdI i diff --git a/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs index 8e958e59ae..9a7c210888 100644 --- a/compiler/GHC/StgToJS/Prim.hs +++ b/compiler/GHC/StgToJS/Prim.hs @@ -961,7 +961,10 @@ fetchOpByteArray op tgt src i v = mconcat , i3_ src i |= op tgt v ] --- lifted arrays +-------------------------------------------------------------------------------- +-- Lifted Arrays +-------------------------------------------------------------------------------- +-- | lifted arrays cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat cloneArray tgt src mb_offset len = mconcat [ tgt |= ApplExpr (src .^ "slice") [start, end] @@ -980,30 +983,6 @@ newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -math :: JExpr -math = var "Math" - -math_ :: ShortText -> [JExpr] -> JExpr -math_ op args = ApplExpr (math .^ op) args - -math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan, - math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh - :: [JExpr] -> JExpr -math_log = math_ "log" -math_sin = math_ "sin" -math_cos = math_ "cos" -math_tan = math_ "tan" -math_exp = math_ "exp" -math_acos = math_ "acos" -math_asin = math_ "asin" -math_atan = math_ "atan" -math_abs = math_ "abs" -math_pow = math_ "pow" ---math_sign = math_ "sign" -math_sqrt = math_ "sqrt" -math_asinh = math_ "asinh" -math_acosh = math_ "acosh" -math_atanh = math_ "atanh" -- e|0 (32 bit signed integer truncation) trunc :: JExpr -> JExpr diff --git a/compiler/GHC/StgToJS/Profiling.hs b/compiler/GHC/StgToJS/Profiling.hs index aac8e66ca4..8042fc562b 100644 --- a/compiler/GHC/StgToJS/Profiling.hs +++ b/compiler/GHC/StgToJS/Profiling.hs @@ -19,6 +19,8 @@ module GHC.StgToJS.Profiling , profiling , ifProfiling , ifProfilingM + -- * helpers + , profStat ) where @@ -124,6 +126,9 @@ ifProfilingM m = do prof <- profiling if prof then m else return mempty +-- | If profiling is enabled, then use input JStat, else ignore +profStat :: StgToJSConfig -> JStat -> JStat +profStat cfg e = if csProf cfg then e else mempty -------------------------------------------------------------------------------- -- Generating cost-centre and cost-centre stack variables diff --git a/compiler/GHC/StgToJS/Regs.hs b/compiler/GHC/StgToJS/Regs.hs index b03bb87907..e8f62a39ad 100644 --- a/compiler/GHC/StgToJS/Regs.hs +++ b/compiler/GHC/StgToJS/Regs.hs @@ -5,8 +5,12 @@ module GHC.StgToJS.Regs , Special(..) , sp , stack - , r1 + , r1, r2, r3, r4 , StgRet (..) + , jsRegToInt + , intToJSReg + , maxReg + , minReg ) where @@ -20,6 +24,18 @@ import qualified GHC.Data.ShortText as ST import Data.Array import Data.Char +-- FIXME: Perf: Jeff (2022,03): as far as I can tell, we never pattern match on +-- these registers and make heavy use of the Enum, Bounded, and Ix, instances. +-- This heavily implies to me that we should be using something like: StgReg = +-- StgReg { unStgReg :: Int8# } and then store two nibbles in a single byte. Not +-- only would this be more memory efficient, but it would also allow for +-- optimizations such as pointer tagging and avoiding chasing the info table, +-- although I'm not sure if this would really benefit the backend as currently +-- written. Other than that a newtype wrapper with a custom bounded instance +-- (hand written or deriving via) would be better. In almost all functions that +-- take an StgReg we use either the Bounded or the Enum methods, thus we likely +-- don't gain anything from having these registers explicitly represented in +-- data constructors. -- | General purpose "registers" -- -- The JS backend arbitrarily supports 128 registers @@ -75,9 +91,26 @@ sp = toJExpr Sp stack :: JExpr stack = toJExpr Stack -r1 :: JExpr +r1, r2, r3, r4 :: JExpr r1 = toJExpr R1 +r2 = toJExpr R2 +r3 = toJExpr R3 +r4 = toJExpr R4 + +-- FIXME: Jeff (2022,03): remove these serialization functions after adding a +-- StgReg type with a proper bounded and enum instance +jsRegToInt :: StgReg -> Int +jsRegToInt = (+1) . fromEnum + +intToJSReg :: Int -> StgReg +intToJSReg r = toEnum (r - 1) + +maxReg :: Int +maxReg = jsRegToInt maxBound + +minReg :: Int +minReg = jsRegToInt minBound --------------------------------------------------- -- caches --------------------------------------------------- diff --git a/compiler/GHC/StgToJS/Types.hs b/compiler/GHC/StgToJS/Types.hs index e0d6e9c86c..02b09a0a7d 100644 --- a/compiler/GHC/StgToJS/Types.hs +++ b/compiler/GHC/StgToJS/Types.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module GHC.StgToJS.Types where import GHC.Prelude @@ -16,7 +19,7 @@ import GHC.Types.ForeignCall import GHC.Types.SrcLoc import GHC.Utils.Monad.State.Strict -import GHC.Utils.Outputable (Outputable (..), text) +import GHC.Utils.Outputable (Outputable (..), text, SDocContext) import GHC.Data.ShortText @@ -52,6 +55,7 @@ data GenGroupState = GenGroupState } data StgToJSConfig = StgToJSConfig + -- flags { csInlinePush :: !Bool , csInlineBlackhole :: !Bool , csInlineLoadRegs :: !Bool @@ -63,6 +67,8 @@ data StgToJSConfig = StgToJSConfig , csTraceForeign :: !Bool , csProf :: !Bool -- ^ Profiling enabled , csRuntimeAssert :: !Bool -- ^ Enable runtime assertions + -- settings + , csContext :: !SDocContext } data ClosureInfo = ClosureInfo @@ -104,10 +110,19 @@ data CIType | CIStackFrame deriving (Eq, Ord) -data CIStatic - = -- CIStaticParent { staticParent :: Ident } -- ^ static refs are stored in parent in fungroup - CIStaticRefs { staticRefs :: [ShortText] } -- ^ list of refs that need to be kept alive - deriving (Eq, Ord) +-- | Static references that must be kept alive +newtype CIStatic = CIStaticRefs { staticRefs :: [ShortText] } + deriving stock (Eq, Ord) + deriving newtype (Semigroup, Monoid) + +-- TODO: Jeff (2022,03): Make ToJExpr derivable? will need Default Signatures +-- and depends on the increase in compilation time + +-- | static refs: array = references, null = nothing to report +-- note: only works after all top-level objects have been created +instance ToJExpr CIStatic where + toJExpr (CIStaticRefs []) = null_ -- [je| null |] + toJExpr (CIStaticRefs rs) = toJExpr (map TxtI rs) -- function argument and free variable types data VarType @@ -123,6 +138,9 @@ data VarType | ArrV -- boxed array deriving (Eq, Ord, Enum, Bounded) +instance ToJExpr VarType where + toJExpr = toJExpr . fromEnum + data IdType = IdPlain | IdEntry @@ -247,8 +265,8 @@ data ExprResult | ExprInline (Maybe [JExpr]) deriving (Eq, Ord, Show) -data ExprValData = ExprValData [JExpr] - deriving (Eq, Ord, Show) +newtype ExprValData = ExprValData [JExpr] + deriving newtype (Eq, Ord, Show) diff --git a/compiler/GHC/StgToJS/UnitUtils.hs b/compiler/GHC/StgToJS/UnitUtils.hs index 2eb37ca72d..61886f43f0 100644 --- a/compiler/GHC/StgToJS/UnitUtils.hs +++ b/compiler/GHC/StgToJS/UnitUtils.hs @@ -7,11 +7,13 @@ module GHC.StgToJS.UnitUtils ) where -import GHC.Prelude + import GHC.Data.ShortText as ST import GHC.Unit.Module import GHC.Utils.Encoding +import GHC.Prelude + unitModuleString :: Module -> String unitModuleString mod = mconcat [ unitIdString (moduleUnitId mod) @@ -19,8 +21,8 @@ unitModuleString mod = mconcat , moduleNameString (moduleName mod) ] --- | the global linkable unit of a module exports this symbol, depend on it to include that unit --- (used for cost centres) +-- | the global linkable unit of a module exports this symbol, depend on it to +-- include that unit (used for cost centres) moduleGlobalSymbol :: Module -> ShortText moduleGlobalSymbol m = mconcat [ "h$" |