[Git][ghc/ghc][wip/js-staging] 2 commits: Refactor Expr

[Sylvain Henry (@hsyl20)]

Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC


Commits:
a5c074c8 by Sylvain Henry at 2022-09-24T10:11:14+02:00
Refactor Expr

- - - - -
fc880b1b by Sylvain Henry at 2022-09-24T10:11:14+02:00
Object: reduce pinned allocation. And don't forget to hClose invalid objects

- - - - -


3 changed files:

- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/Utils/Binary.hs


Changes:

=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -74,6 +74,7 @@ import qualified Data.Map as M
 import Control.Monad
 import Control.Arrow ((&&&))
 
+-- | Evaluate an expression in the given expression context (continuation)
 genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
 genExpr ctx stg = case stg of
   StgApp f args -> genApp ctx f args
@@ -287,17 +288,32 @@ genBody :: HasDebugCallStack
          -> CgStgExpr
          -> G JStat
 genBody ctx i startReg args e = do
-  la <- loadArgs startReg args
+  -- load arguments into local variables
+  la <- do
+    args' <- concatMapM genIdArgI args
+    return (declAssignAll args' (fmap toJExpr [startReg..]))
+
+  -- assert that arguments have valid runtime reps
   lav <- verifyRuntimeReps args
-  let ids :: [TypedExpr]
-      ids = -- take (resultSize args $ idType i) jsRegsFromR1
-            reverse . fst $
-            foldl' (\(rs, vs) (rep, size) ->
-                       let (vs0, vs1) = splitAt size vs
-                       in  (TypedExpr rep vs0:rs,vs1))
-                   ([], jsRegsFromR1)
-                   (resultSize args $ idType i)
-  (e, _r) <- genExpr (ctx { ctxTarget = ids }) e
+
+  -- compute PrimReps and their number of slots required to return the result of
+  -- i applied to args.
+  let res_vars = resultSize args (idType i)
+
+  -- compute typed expressions for each slot and assign registers
+  let go_var regs = \case
+        []              -> []
+        ((rep,size):rs) ->
+          let !(regs0,regs1) = splitAt size regs
+              !ts = go_var regs1 rs
+          in TypedExpr rep regs0 : ts
+
+  let tgt  = go_var jsRegsFromR1 res_vars
+  let !ctx' = ctx { ctxTarget = tgt }
+
+  -- generate code for the expression
+  (e, _r) <- genExpr ctx' e
+
   return $ la <> lav <> e <> returnStack
 
 -- find the result type after applying the function to the arguments
@@ -339,11 +355,6 @@ resultSize [] t
   where
     t' = unwrapType t
 
-loadArgs :: HasDebugCallStack => StgReg -> [Id] -> G JStat
-loadArgs start args = do
-  args' <- concatMapM genIdArgI args
-  return (declAssignAll args' (fmap toJExpr [start..]))
-
 verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStat
 verifyRuntimeReps xs = do
   runtime_assert <- csRuntimeAssert <$> getSettings


=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -72,6 +72,9 @@ import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.Word
 import           Data.Char
+import Foreign.Storable
+import Foreign.Marshal.Array
+import System.IO
 
 import GHC.Settings.Constants (hiVersion)
 
@@ -235,20 +238,28 @@ putObject bh mod_name deps os = do
 
 -- | Test if the object file is a JS object
 isJsObjectFile :: FilePath -> IO Bool
-isJsObjectFile fp =
-  readBinMemN (length magic) fp >>= \case
-    Nothing -> pure False
-    Just bh -> getCheckMagic bh
+isJsObjectFile fp = do
+  let !n = length magic
+  withBinaryFile fp ReadMode $ \hdl -> do
+    allocaArray n $ \ptr -> do
+      n' <- hGetBuf hdl ptr n
+      if (n' /= n)
+        then pure False
+        else checkMagic (peekElemOff ptr)
+
+-- | Check magic
+checkMagic :: (Int -> IO Word8) -> IO Bool
+checkMagic get_byte = do
+  let go_magic !i = \case
+        []     -> pure True
+        (e:es) -> get_byte i >>= \case
+          c | fromIntegral (ord e) == c -> go_magic (i+1) es
+            | otherwise                 -> pure False
+  go_magic 0 magic
 
 -- | Parse object magic
 getCheckMagic :: BinHandle -> IO Bool
-getCheckMagic bh = do
-  let go_magic = \case
-        []     -> pure True
-        (e:es) -> getByte bh >>= \case
-          c | fromIntegral (ord e) == c -> go_magic es
-            | otherwise                 -> pure False
-  go_magic magic
+getCheckMagic bh = checkMagic (const (getByte bh))
 
 -- | Parse object header
 getObjectHeader :: BinHandle -> IO (Either String ModuleName)


=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -289,19 +289,19 @@ writeBinMem (BinMem _ ix_r _ arr_r) fn = do
 
 readBinMem :: FilePath -> IO BinHandle
 readBinMem filename = do
-  h <- openBinaryFile filename ReadMode
-  filesize' <- hFileSize h
-  let filesize = fromIntegral filesize'
-  readBinMem_ filesize h
+  withBinaryFile filename ReadMode $ \h -> do
+    filesize' <- hFileSize h
+    let filesize = fromIntegral filesize'
+    readBinMem_ filesize h
 
 readBinMemN :: Int -> FilePath -> IO (Maybe BinHandle)
 readBinMemN size filename = do
-  h <- openBinaryFile filename ReadMode
-  filesize' <- hFileSize h
-  let filesize = fromIntegral filesize'
-  if filesize < size
-    then pure Nothing
-    else Just <$> readBinMem_ size h
+  withBinaryFile filename ReadMode $ \h -> do
+    filesize' <- hFileSize h
+    let filesize = fromIntegral filesize'
+    if filesize < size
+      then pure Nothing
+      else Just <$> readBinMem_ size h
 
 readBinMem_ :: Int -> Handle -> IO BinHandle
 readBinMem_ filesize h = do
@@ -309,7 +309,6 @@ readBinMem_ filesize h = do
   count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize
   when (count /= filesize) $
        error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
-  hClose h
   arr_r <- newIORef arr
   ix_r <- newFastMutInt 0
   sz_r <- newFastMutInt filesize



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f2304e401ff2ed1241355b64e8e1ac91b6b6d7ce...fc880b1bed25ff401820d269821dd3d7eaafd358

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f2304e401ff2ed1241355b64e8e1ac91b6b6d7ce...fc880b1bed25ff401820d269821dd3d7eaafd358
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220924/773e360f/attachment-0001.html>