[Git][ghc/ghc][wip/js-staging] 3 commits: Remove warning about orphan instance
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Fri Aug 26 14:24:17 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
1c6d843a by Sylvain Henry at 2022-08-26T15:28:55+02:00
Remove warning about orphan instance
- - - - -
cdd94dd0 by Sylvain Henry at 2022-08-26T15:37:09+02:00
Compactor: disable dead code
- - - - -
542c87ac by Sylvain Henry at 2022-08-26T15:46:45+02:00
Exception: implement raiseUnderflow etc. as primops
- - - - -
8 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Linker/Compactor.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Linker/Types.hs
- compiler/GHC/StgToJS/Prim.hs
- js/rts.js.pp
- libraries/ghc-prim/GHC/Prim/Exception.hs
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2573,6 +2573,27 @@ primop RaiseOp "raise#" GenPrimOp
out_of_line = True
can_fail = True
+primop RaiseUnderflowOp "raiseUnderflow#" GenPrimOp
+ (# #) -> p
+ with
+ strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }
+ out_of_line = True
+ can_fail = True
+
+primop RaiseOverflowOp "raiseOverflow#" GenPrimOp
+ (# #) -> p
+ with
+ strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }
+ out_of_line = True
+ can_fail = True
+
+primop RaiseDivZeroOp "raiseDivZero#" GenPrimOp
+ (# #) -> p
+ with
+ strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }
+ out_of_line = True
+ can_fail = True
+
primop RaiseIOOp "raiseIO#" GenPrimOp
v -> State# RealWorld -> (# State# RealWorld, p #)
with
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1563,6 +1563,9 @@ emitPrimOp cfg primop =
CasMutVarOp -> alwaysExternal
CatchOp -> alwaysExternal
RaiseOp -> alwaysExternal
+ RaiseUnderflowOp -> alwaysExternal
+ RaiseOverflowOp -> alwaysExternal
+ RaiseDivZeroOp -> alwaysExternal
RaiseIOOp -> alwaysExternal
MaskAsyncExceptionsOp -> alwaysExternal
MaskUninterruptibleOp -> alwaysExternal
=====================================
compiler/GHC/StgToJS/Linker/Compactor.hs
=====================================
@@ -49,14 +49,11 @@ import Control.Applicative
import GHC.Utils.Monad.State.Strict
import Data.Function
-import qualified Data.Bits as Bits
-import Data.Bits (shiftL, shiftR)
import Data.Bifunctor (second)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Builder as BB
-import Data.Char (chr)
import qualified Data.Graph as G
import qualified Data.Map.Strict as M
import Data.Map (Map)
@@ -64,7 +61,6 @@ import Data.Int
import qualified Data.List as List
import Data.Maybe
import qualified Data.Set as S
-import Data.Set (Set)
import GHC.Data.FastString
import GHC.JS.Syntax
@@ -73,7 +69,6 @@ import GHC.JS.Transform
import GHC.StgToJS.Printer (pretty)
import GHC.StgToJS.Types
import GHC.StgToJS.Linker.Types
-import GHC.StgToJS.CoreUtils
import GHC.StgToJS.Closure
import GHC.StgToJS.Arg
@@ -417,6 +412,7 @@ renameObj xs = do
modify (addStaticEntry xs') -- and now the table
return xs'
+{-
renameEntry :: Ident
-> State CompactorState Ident
renameEntry i = do
@@ -436,6 +432,7 @@ collectLabels si = mapM_ go (labelsV . siVal $ si)
labelsA _ = []
labelsL (LabelLit _ lbl) = [lbl]
labelsL _ = []
+-}
lookupRenamed :: CompactorState -> Ident -> Ident
lookupRenamed cs i@(TxtI t) =
@@ -502,6 +499,7 @@ staticIdentsA f (StaticObjArg t) = StaticObjArg $! f t
staticIdentsA _ x = x
+{-
{-
simple encoding of naturals using only printable low char points,
rely on gzip to compress repeating sequences,
@@ -731,6 +729,8 @@ encodeDouble (SaneDouble d)
encodeMax :: Integer
encodeMax = 737189
+-}
+
{- |
The Base data structure contains the information we need
to do incremental linking against a base bundle.
@@ -953,6 +953,7 @@ findLocals (BlockStat ss) = concatMap findLocals ss
findLocals (DeclStat (TxtI i)) = [i]
findLocals _ = []
+{-
nub' :: Ord a => [a] -> [a]
nub' = go S.empty
where
@@ -960,6 +961,7 @@ nub' = go S.empty
go s (x:xs)
| x `S.member` s = go s xs
| otherwise = x : go (S.insert x s) xs
+-}
data HashIdx = HashIdx (UniqMap FastString Hash) (Map Hash FastString)
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -662,12 +662,16 @@ readSystemDeps' file
, S.fromList $ d baseUnitId "GHC.JS.Prim.TH.Eval" ["runTHServer"])
| file == "rtsdeps.yaml" = pure ( [ baseUnitId
, primUnitId
- , bignumUnitId
]
, S.fromList $ concat
[ d baseUnitId "GHC.Conc.Sync" ["reportError"]
, d baseUnitId "Control.Exception.Base" ["nonTermination"]
- , d baseUnitId "GHC.Exception.Type" ["SomeException"]
+ , d baseUnitId "GHC.Exception.Type"
+ [ "SomeException"
+ , "underflowException"
+ , "overflowException"
+ , "divZeroException"
+ ]
, d baseUnitId "GHC.TopHandler" ["runMainIO", "topHandler"]
, d baseUnitId "GHC.Base" ["$fMonadIO"]
, d baseUnitId "GHC.Maybe" ["Nothing", "Just"]
=====================================
compiler/GHC/StgToJS/Linker/Types.hs
=====================================
@@ -1,6 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
+{-# OPTIONS_GHC -Wno-orphans #-} -- for Ident's Binary instance
+
-----------------------------------------------------------------------------
-- |
-- Module : GHC.StgToJS.Linker.Types
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -866,6 +866,9 @@ genPrim prof ty op = case op of
-- slots, depending on the return type.
RaiseOp -> \_r [a] -> PRPrimCall $ returnS (app "h$throw" [a, false_])
RaiseIOOp -> \_r [a] -> PRPrimCall $ returnS (app "h$throw" [a, false_])
+ RaiseUnderflowOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypeziunderflowException", false_])
+ RaiseOverflowOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypezioverflowException", false_])
+ RaiseDivZeroOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypezidivZZeroException", false_])
MaskAsyncExceptionsOp -> \_r [a] -> PRPrimCall $ returnS (app "h$maskAsync" [a])
MaskUninterruptibleOp -> \_r [a] -> PRPrimCall $ returnS (app "h$maskUnintAsync" [a])
UnmaskAsyncExceptionsOp -> \_r [a] -> PRPrimCall $ returnS (app "h$unmaskAsync" [a])
=====================================
js/rts.js.pp
=====================================
@@ -710,4 +710,4 @@ function h$keepAlive(x, f) {
h$stack[h$sp] = h$keepAlive_e;
h$r1 = f;
return h$ap_1_0_fast();
-}
\ No newline at end of file
+}
=====================================
libraries/ghc-prim/GHC/Prim/Exception.hs
=====================================
@@ -1,9 +1,6 @@
-{-# LANGUAGE GHCForeignImportPrim #-}
-{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE EmptyCase #-}
-- | Primitive exceptions.
module GHC.Prim.Exception
@@ -14,7 +11,7 @@ module GHC.Prim.Exception
where
import GHC.Prim
-import GHC.Magic
+import GHC.Types ()
default () -- Double and Integer aren't available yet
@@ -29,10 +26,6 @@ default () -- Double and Integer aren't available yet
--
-- See also: Note [Wired-in exceptions are not CAFfy] in GHC.Core.Make.
-foreign import prim "stg_raiseOverflowzh" raiseOverflow# :: State# RealWorld -> (# State# RealWorld, (# #) #)
-foreign import prim "stg_raiseUnderflowzh" raiseUnderflow# :: State# RealWorld -> (# State# RealWorld, (# #) #)
-foreign import prim "stg_raiseDivZZerozh" raiseDivZero# :: State# RealWorld -> (# State# RealWorld, (# #) #)
-
-- We give a bottoming demand signature to 'raiseOverflow', 'raiseUnderflow' and
-- 'raiseDivZero' in "GHC.Core.Make". NOINLINE pragmas are necessary because if
-- we ever inlined them we would lose that information.
@@ -40,14 +33,14 @@ foreign import prim "stg_raiseDivZZerozh" raiseDivZero# :: State# RealWorld -> (
-- | Raise 'GHC.Exception.Type.overflowException'
raiseOverflow :: a
{-# NOINLINE raiseOverflow #-}
-raiseOverflow = runRW# (\s -> case raiseOverflow# s of (# _, _ #) -> let x = x in x)
+raiseOverflow = raiseOverflow# (# #)
-- | Raise 'GHC.Exception.Type.underflowException'
raiseUnderflow :: a
{-# NOINLINE raiseUnderflow #-}
-raiseUnderflow = runRW# (\s -> case raiseUnderflow# s of (# _, _ #) -> let x = x in x)
+raiseUnderflow = raiseUnderflow# (# #)
-- | Raise 'GHC.Exception.Type.divZeroException'
raiseDivZero :: a
{-# NOINLINE raiseDivZero #-}
-raiseDivZero = runRW# (\s -> case raiseDivZero# s of (# _, _ #) -> let x = x in x)
+raiseDivZero = raiseDivZero# (# #)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8764ef83d8d04b92299b3109ceba2a00efcf8b03...542c87acae7d0e0a6e7e4d2b8b4d91a080c4809f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8764ef83d8d04b92299b3109ceba2a00efcf8b03...542c87acae7d0e0a6e7e4d2b8b4d91a080c4809f
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/20220826/9fdcf38f/attachment-0001.html>
More information about the ghc-commits
mailing list