[Git][ghc/ghc][wip/js-staging] 4 commits: fixup: misc. fixes post rebase
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Fri Aug 12 12:33:04 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
060791a8 by doyougnu at 2022-08-12T14:34:59+02:00
fixup: misc. fixes post rebase
- - - - -
a2d693ce by Sylvain Henry at 2022-08-12T14:34:59+02:00
PrimOps: add more 64-bit primops
- - - - -
9eae0d8e by Sylvain Henry at 2022-08-12T14:34:59+02:00
PrimOp: implement more 64-bit primops + PM fix
Ensure that we cover every primop explicitly
- - - - -
f10b4f79 by Sylvain Henry at 2022-08-12T14:34:59+02:00
Fix more redundant imports
- - - - -
11 changed files:
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/StgToJS/Arg.hs
- compiler/GHC/StgToJS/DataCon.hs
- compiler/GHC/StgToJS/Linker/Compactor.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Literal.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/StgToJS/Types.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- js/arith.js.pp
Changes:
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -842,8 +842,8 @@ cmmPipeline pipe_env hsc_env input_fn = do
-- | This JS pipeline is just a no-op because the JS backend short circuits to
-- 'GHC.StgToJS' before Cmm
-jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
-jsPipeline _ _ _ input_fn = pure input_fn -- .o file has been generated by StgToJS
+jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
+jsPipeline _ _ _ input_fn = pure $! pure input_fn -- .o file has been generated by StgToJS
hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing
@@ -859,9 +859,9 @@ applyPostHscPipeline NcgPostHscPipeline =
\pe he ml fp -> asPipeline False pe he ml fp
applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc
applyPostHscPipeline LlvmPostHscPipeline =
- \pe he ml fp -> Just <$> llvmPipeline pe he ml fp
+ \pe he ml fp -> llvmPipeline pe he ml fp
applyPostHscPipeline JSPostHscPipeline =
- \pe he ml fp -> Just <$> jsPipeline pe he ml fp
+ \pe he ml fp -> jsPipeline pe he ml fp
applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing
-- Pipeline from a given suffix
=====================================
compiler/GHC/StgToJS/Arg.hs
=====================================
@@ -28,7 +28,6 @@ import GHC.StgToJS.Profiling
import GHC.Builtin.Types
import GHC.Stg.Syntax
import GHC.Core.DataCon
-import GHC.Data.FastString
import GHC.Types.CostCentre
import GHC.Types.Unique.FM
=====================================
compiler/GHC/StgToJS/DataCon.hs
=====================================
@@ -32,7 +32,6 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
-import qualified Data.Map as M
import Data.Maybe
genCon :: ExprCtx -> DataCon -> [JExpr] -> G JStat
=====================================
compiler/GHC/StgToJS/Linker/Compactor.hs
=====================================
@@ -1203,7 +1203,7 @@ fixHashesIter n invDeps allKeys checkKeys sccs hashes finalHashes
lookupDep (LexicalFastString d)
| Just b <- lookupUniqMap finalHashes d = b
| Just i <- lookupUniqMap toHashIdx d
- = grpHash <> (utf8EncodeString . show $ i)
+ = grpHash <> (utf8EncodeByteString . show $ i)
| otherwise
= panic $ "Gen2.Compactor.hashRootSCC: unknown key: " ++
unpackFS d
@@ -1287,7 +1287,7 @@ hd d = HashBuilder (BB.doubleLE d) []
htxt :: FastString -> HashBuilder
htxt x = HashBuilder (BB.int64LE (fromIntegral $ BS.length bs) <> BB.byteString bs) []
where
- bs = utf8EncodeString $ unpackFS x
+ bs = utf8EncodeByteString $ unpackFS x
hobj :: FastString -> HashBuilder
hobj x = HashBuilder (BB.int8 127) [x]
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -124,7 +124,7 @@ import System.Directory ( createDirectoryIfMissing
)
import GHC.Driver.Session (targetWays_, DynFlags(..))
-import GHC.Unit.Module.Name
+import Language.Haskell.Syntax.Module.Name
import GHC.Unit.Module (moduleStableString)
import GHC.Utils.Logger (Logger)
import GHC.Utils.TmpFs (TmpFs)
=====================================
compiler/GHC/StgToJS/Literal.hs
=====================================
@@ -23,7 +23,6 @@ import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Float
-import qualified Data.ByteString.Short as Short
import Data.Bits as Bits
import Data.Char (ord)
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -113,7 +113,6 @@ import GHC.StgToJS.Types
import GHC.Unit.Module
import GHC.Data.FastString
-import GHC.Data.ShortText as ST
import GHC.Types.Unique.Map
import GHC.Float (castDoubleToWord64, castWord64ToDouble)
@@ -814,4 +813,4 @@ instance Binary StaticLit where
5 -> StringLit <$> get bh
6 -> BinLit <$> get bh
7 -> LabelLit <$> get bh <*> get bh
- n -> error ("Binary get bh StaticLit: invalid tag " ++ show n)
\ No newline at end of file
+ n -> error ("Binary get bh StaticLit: invalid tag " ++ show n)
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -40,7 +40,7 @@ genPrim :: Bool -- ^ Profiling (cost-centres) enabled
-> [JExpr] -- ^ where to store the result
-> [JExpr] -- ^ arguments
-> PrimRes
-genPrim prof ty = \case
+genPrim prof ty op = case op of
CharGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y)
CharGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y)
CharEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y)
@@ -321,10 +321,12 @@ genPrim prof ty = \case
, r2 |= x2
]
- Word64EqOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1))
- Word64NeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1))
-
- Word64AddOp -> \[hr,hl] [h0, l0, h1, l1] -> PrimInline $ appT [hr, hl] "h$hs_plusInt64" [h0, l0, h1, l1]
+ Word64EqOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1))
+ Word64NeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1))
+ Word64GeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .!==. h1) (l0 .>=. l1)))
+ Word64GtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .!==. h1) (l0 .>. l1)))
+ Word64LeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .!==. h1) (l0 .<=. l1)))
+ Word64LtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .!==. h1) (l0 .<. l1)))
Word64SllOp -> \[hr,hl] [h, l, n] -> PrimInline $ appT [hr, hl] "h$hs_uncheckedIShiftL64" [h, l, n]
Word64SrlOp -> \[hr,hl] [h, l, n] -> PrimInline $ appT [hr, hl] "h$hs_uncheckedShiftRL64" [h, l, n]
@@ -354,6 +356,12 @@ genPrim prof ty = \case
, hl |= BNot l
]
+ Word64AddOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_plusWord64" [h0,l0,h1,l1]
+ Word64SubOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_minusWord64" [h0,l0,h1,l1]
+ Word64MulOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_timesWord64" [h0,l0,h1,l1]
+ Word64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_quotWord64" [h0,l0,h1,l1]
+ Word64RemOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_remWord64" [h0,l0,h1,l1]
+
------------------------------ Word ---------------------------------------------
WordAddOp -> \[r] [x,y] -> PrimInline $ r |= (x `Add` y) .>>>. zero_
@@ -1012,77 +1020,162 @@ genPrim prof ty = \case
TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len]
TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo]
--- FIXME: Sylvain (2022-06) We want to support every primop, or disable them
--- explicitly. So we should remove this catch-all case ultimately, or make it
--- crash at compilation time.
- op -> \rs as -> PrimInline $ mconcat
- [ appS "h$log" [toJExpr $ mconcat
- [ "warning, unhandled primop: "
- , renderWithContext defaultSDocContext (ppr op)
- , " "
- , show (length rs, length as)
- ]]
- , appS (mkFastString $ "h$primop_" ++ zEncodeString (renderWithContext defaultSDocContext (ppr op))) as
- -- copyRes
- , mconcat $ zipWith (\r reg -> r |= toJExpr reg) rs (enumFrom Ret1)
- ]
-
-{- new ops in 8.6
- , IndexByteArrayOp_Word8AsChar
- , IndexByteArrayOp_Word8AsWideChar
- , IndexByteArrayOp_Word8AsAddr
- , IndexByteArrayOp_Word8AsFloat
- , IndexByteArrayOp_Word8AsDouble
- , IndexByteArrayOp_Word8AsStablePtr
- , IndexByteArrayOp_Word8AsInt16
- , IndexByteArrayOp_Word8AsInt32
- , IndexByteArrayOp_Word8AsInt64
- , IndexByteArrayOp_Word8AsInt
- , IndexByteArrayOp_Word8AsWord16
- , IndexByteArrayOp_Word8AsWord32
- , IndexByteArrayOp_Word8AsWord64
- , IndexByteArrayOp_Word8AsWord
-
- , ReadByteArrayOp_Word8AsChar
- , ReadByteArrayOp_Word8AsWideChar
- , ReadByteArrayOp_Word8AsAddr
- , ReadByteArrayOp_Word8AsFloat
- , ReadByteArrayOp_Word8AsDouble
- , ReadByteArrayOp_Word8AsStablePtr
- , ReadByteArrayOp_Word8AsInt16
- , ReadByteArrayOp_Word8AsInt32
- , ReadByteArrayOp_Word8AsInt64
- , ReadByteArrayOp_Word8AsInt
- , ReadByteArrayOp_Word8AsWord16
- , ReadByteArrayOp_Word8AsWord32
- , ReadByteArrayOp_Word8AsWord64
- , ReadByteArrayOp_Word8AsWord
- , WriteByteArrayOp_Word8AsChar
- , WriteByteArrayOp_Word8AsWideChar
- , WriteByteArrayOp_Word8AsAddr
- , WriteByteArrayOp_Word8AsFloat
- , WriteByteArrayOp_Word8AsDouble
- , WriteByteArrayOp_Word8AsStablePtr
- , WriteByteArrayOp_Word8AsInt16
- , WriteByteArrayOp_Word8AsInt32
- , WriteByteArrayOp_Word8AsInt64
- , WriteByteArrayOp_Word8AsInt
- , WriteByteArrayOp_Word8AsWord16
- , WriteByteArrayOp_Word8AsWord32
- , WriteByteArrayOp_Word8AsWord64
- , WriteByteArrayOp_Word8AsWord
- -}
-{-
-AnyToAddrOp
-MkApUpd0_Op
-NewBCOOp
-UnpackClosureOp
-GetApStackValOp
--}
-
-{-
-GetSparkOp
--}
+------------------------------ Unhandled primops -------------------
+
+ BRevOp -> unhandledPrimop op
+ BRev8Op -> unhandledPrimop op
+ BRev16Op -> unhandledPrimop op
+ BRev32Op -> unhandledPrimop op
+ BRev64Op -> unhandledPrimop op
+
+ DoubleExpM1Op -> unhandledPrimop op
+ DoubleLog1POp -> unhandledPrimop op
+ FloatExpM1Op -> unhandledPrimop op
+ FloatLog1POp -> unhandledPrimop op
+
+ ShrinkSmallMutableArrayOp_Char -> unhandledPrimop op
+ GetSizeofSmallMutableArrayOp -> unhandledPrimop op
+
+ IndexByteArrayOp_Word8AsChar -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsWideChar -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsAddr -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsFloat -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsDouble -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsStablePtr -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsInt16 -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsInt32 -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsInt64 -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsInt -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsWord16 -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsWord32 -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsWord64 -> unhandledPrimop op
+ IndexByteArrayOp_Word8AsWord -> unhandledPrimop op
+
+ ReadByteArrayOp_Word8AsChar -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsWideChar -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsAddr -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsFloat -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsDouble -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsStablePtr -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsInt16 -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsInt32 -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsInt64 -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsInt -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsWord16 -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsWord32 -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsWord64 -> unhandledPrimop op
+ ReadByteArrayOp_Word8AsWord -> unhandledPrimop op
+
+ WriteByteArrayOp_Word8AsChar -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsWideChar -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsAddr -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsFloat -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsDouble -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsStablePtr -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsInt16 -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsInt32 -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsInt64 -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsInt -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsWord16 -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsWord32 -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsWord64 -> unhandledPrimop op
+ WriteByteArrayOp_Word8AsWord -> unhandledPrimop op
+
+ CasByteArrayOp_Int8 -> unhandledPrimop op
+ CasByteArrayOp_Int16 -> unhandledPrimop op
+ CasByteArrayOp_Int32 -> unhandledPrimop op
+ CasByteArrayOp_Int64 -> unhandledPrimop op
+
+ InterlockedExchange_Addr -> unhandledPrimop op
+ InterlockedExchange_Word -> unhandledPrimop op
+
+ CasAddrOp_Addr -> unhandledPrimop op
+ CasAddrOp_Word -> unhandledPrimop op
+ CasAddrOp_Word8 -> unhandledPrimop op
+ CasAddrOp_Word16 -> unhandledPrimop op
+ CasAddrOp_Word32 -> unhandledPrimop op
+ CasAddrOp_Word64 -> unhandledPrimop op
+
+ FetchAddAddrOp_Word -> unhandledPrimop op
+ FetchSubAddrOp_Word -> unhandledPrimop op
+ FetchAndAddrOp_Word -> unhandledPrimop op
+ FetchNandAddrOp_Word -> unhandledPrimop op
+ FetchOrAddrOp_Word -> unhandledPrimop op
+ FetchXorAddrOp_Word -> unhandledPrimop op
+
+ AtomicReadAddrOp_Word -> unhandledPrimop op
+ AtomicWriteAddrOp_Word -> unhandledPrimop op
+
+ NewIOPortOp -> unhandledPrimop op
+ ReadIOPortOp -> unhandledPrimop op
+ WriteIOPortOp -> unhandledPrimop op
+
+ KeepAliveOp -> unhandledPrimop op
+
+ GetSparkOp -> unhandledPrimop op
+ AnyToAddrOp -> unhandledPrimop op
+ MkApUpd0_Op -> unhandledPrimop op
+ NewBCOOp -> unhandledPrimop op
+ UnpackClosureOp -> unhandledPrimop op
+ ClosureSizeOp -> unhandledPrimop op
+ GetApStackValOp -> unhandledPrimop op
+ WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n
+ SetThreadAllocationCounter -> unhandledPrimop op
+
+ VecBroadcastOp _ _ _ -> unhandledPrimop op
+ VecPackOp _ _ _ -> unhandledPrimop op
+ VecUnpackOp _ _ _ -> unhandledPrimop op
+ VecInsertOp _ _ _ -> unhandledPrimop op
+ VecAddOp _ _ _ -> unhandledPrimop op
+ VecSubOp _ _ _ -> unhandledPrimop op
+ VecMulOp _ _ _ -> unhandledPrimop op
+ VecDivOp _ _ _ -> unhandledPrimop op
+ VecQuotOp _ _ _ -> unhandledPrimop op
+ VecRemOp _ _ _ -> unhandledPrimop op
+ VecNegOp _ _ _ -> unhandledPrimop op
+ VecIndexByteArrayOp _ _ _ -> unhandledPrimop op
+ VecReadByteArrayOp _ _ _ -> unhandledPrimop op
+ VecWriteByteArrayOp _ _ _ -> unhandledPrimop op
+ VecIndexOffAddrOp _ _ _ -> unhandledPrimop op
+ VecReadOffAddrOp _ _ _ -> unhandledPrimop op
+ VecWriteOffAddrOp _ _ _ -> unhandledPrimop op
+
+ VecIndexScalarByteArrayOp _ _ _ -> unhandledPrimop op
+ VecReadScalarByteArrayOp _ _ _ -> unhandledPrimop op
+ VecWriteScalarByteArrayOp _ _ _ -> unhandledPrimop op
+ VecIndexScalarOffAddrOp _ _ _ -> unhandledPrimop op
+ VecReadScalarOffAddrOp _ _ _ -> unhandledPrimop op
+ VecWriteScalarOffAddrOp _ _ _ -> unhandledPrimop op
+
+ PrefetchByteArrayOp3 -> unhandledPrimop op
+ PrefetchMutableByteArrayOp3 -> unhandledPrimop op
+ PrefetchAddrOp3 -> unhandledPrimop op
+ PrefetchValueOp3 -> unhandledPrimop op
+ PrefetchByteArrayOp2 -> unhandledPrimop op
+ PrefetchMutableByteArrayOp2 -> unhandledPrimop op
+ PrefetchAddrOp2 -> unhandledPrimop op
+ PrefetchValueOp2 -> unhandledPrimop op
+ PrefetchByteArrayOp1 -> unhandledPrimop op
+ PrefetchMutableByteArrayOp1 -> unhandledPrimop op
+ PrefetchAddrOp1 -> unhandledPrimop op
+ PrefetchValueOp1 -> unhandledPrimop op
+ PrefetchByteArrayOp0 -> unhandledPrimop op
+ PrefetchMutableByteArrayOp0 -> unhandledPrimop op
+ PrefetchAddrOp0 -> unhandledPrimop op
+ PrefetchValueOp0 -> unhandledPrimop op
+
+unhandledPrimop :: PrimOp -> [JExpr] -> [JExpr] -> PrimRes
+unhandledPrimop op rs as = PrimInline $ mconcat
+ [ appS "h$log" [toJExpr $ mconcat
+ [ "warning, unhandled primop: "
+ , renderWithContext defaultSDocContext (ppr op)
+ , " "
+ , show (length rs, length as)
+ ]]
+ , appS (mkFastString $ "h$primop_" ++ zEncodeString (renderWithContext defaultSDocContext (ppr op))) as
+ -- copyRes
+ , mconcat $ zipWith (\r reg -> r |= toJExpr reg) rs (enumFrom Ret1)
+ ]
-- tuple returns
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -9,7 +9,7 @@ import GHC.Prelude
import GHC.JS.Syntax
import GHC.JS.Make
-import GHC.JS.Ppr
+import GHC.JS.Ppr ()
import GHC.Stg.Syntax
import GHC.Core.TyCon
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -326,7 +326,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh
| cconv == JavaScriptCallConv = do
checkCg (Right idecl) backendValidityOfCImport
-- leave the rest to the JS backend (at least for now)
- return idecl
+ return (CImport src (L lc cconv) (L ls safety) mh (CFunction target))
| otherwise = do -- Normal foreign import
checkCg (Right idecl) backendValidityOfCImport
cconv' <- checkCConv (Right idecl) cconv
=====================================
js/arith.js.pp
=====================================
@@ -7,6 +7,8 @@ function h$logArith() { h$log.apply(h$log,arguments); }
#define TRACE_ARITH(args...)
#endif
+#define UN(x) ((x)>>>0)
+
function h$hs_leInt64(h1,l1,h2,l2) {
if(h1 === h2) {
var l1s = l1 >>> 1;
@@ -48,15 +50,82 @@ function h$hs_gtInt64(h1,l1,h2,l2) {
}
function h$hs_quotWord64(h1,l1,h2,l2) {
- throw "hs_quotWord64 not implemented yet";
- // var a = h$ghcjsbn_mkBigNat_ww(h1,l1); // bigFromWord64(h1,l1);
- // var b = h$ghcjsbn_mkBigNat_ww(h2,l2); // bigFromWord64(h2,l2);
- var q = h$ghcjsbn_quot_bb(h$ghcjsbn_mkBigNat_ww(h1,l1),
- h$ghcjsbn_mkBigNat_ww(h2,l2));
- return h$ghcjsbn_toWord64_b(q); // this should return the tuple
- //RETURN_UBX_TUP2(h$ghcjsbn_toWord_b(h$ghcjsbn_shr_b(q, 32))
- // a.divide(b);
- // RETURN_UBX_TUP2(c.shiftRight(32).intValue(), c.intValue());
+ // algorithm adapted from Hacker's Delight p198
+
+ // if divisor > numerator, just return 0
+ if ((h2 > h1) || (h2 === h1 && l2 > l1)) {
+ RETURN_UBX_TUP2(0,0);
+ }
+
+ if (h2 === 0) {
+ if (h1 < l2) {
+ var ql = h$quotRem2Word32(h1,l1,l2);
+ RETURN_UBX_TUP2(0,ql);
+ }
+ else {
+ var qh = h$quotRem2Word32(0,h1,l2);
+ var rh = h$ret1; // remainder
+ var ql = h$quotRem2Word32(rh,l1,l2);
+ RETURN_UBX_TUP2(qh,ql);
+ }
+ }
+ else {
+ var n = Math.clz32(h2);
+ // normalize divisor (MSB = 1)
+ var dh = UN((h2 << n) | (l2 >>> (32-n)));
+ // shift numerator 1 bit right (MSB = 0)
+ var nh = h1 >>> 1;
+ var nl = UN((h1 << 31) | (l1 >>> 1));
+ // compute quotient estimation
+ var q1 = h$quotRem2Word32(nh,nl,dh);
+ // undo normalization and division of numerator by 2
+ var q0 = q1 >>> (31 - n);
+ if (q0 !== 0) {
+ q0 = UN(q0 - 1);
+ }
+ // q0 might be too small by 1. q0*arg2 doesn't overflow
+ var q0vh = h$hs_timesWord64(h2,l2,0,q0);
+ var q0vl = h$ret1;
+ var sh = h$hs_minusWord64(h1,l1,q0vh,q0vl);
+ var sl = h$ret1;
+ if ((sh > h2) || (sh === h2 && sl >= l2)) {
+ q0 = UN(q0 + 1);
+ }
+ RETURN_UBX_TUP2(0,q0);
+ }
+}
+
+function h$hs_remWord64(h1,l1,h2,l2) {
+ var qh = h$hs_quotWord64(h1,l1,h2,l2);
+ var ql = h$ret1;
+ var qvh = h$hs_timesWord64(h2,l2,qh,ql);
+ var qvl = h$ret1;
+ return h$hs_minusWord64(h1,l1,qvh,qvl);
+}
+
+function h$hs_timesWord64(h1,l1,h2,l2) {
+ var rl = UN(l1 * l2);
+ var rh = UN(UN(l2 * h1) + UN(l1 * h2));
+ RETURN_UBX_TUP2(rh,rl);
+}
+
+function h$hs_minusWord64(h1,l1,h2,l2) {
+ var b = l2 > l1 ? 1 : 0
+ var rl = UN(l1 - l2);
+ var rh = UN(UN(h2 - h1) - b);
+ RETURN_UBX_TUP2(rh,rl);
+}
+
+function h$hs_plusWord64(h1,l1,h2,l2) {
+ var c1 = (l1 & 0x80000000) >>> 31;
+ var c2 = (l2 & 0x80000000) >>> 31;
+ var rl = UN(l1 & 0x7FFFFFFF) + UN(l1 & 0x7FFFFFFF);
+ var cr = (rl & 0x80000000) >>> 31;
+ var rh = UN(h1+h2);
+ var c = UN(c1+c2+cr);
+ rl = UN(rl + UN(c << 31));
+ rh = UN(rh + (c >>> 1));
+ RETURN_UBX_TUP2(rh,rl);
}
function h$hs_timesInt64(h1,l1,h2,l2) {
@@ -435,8 +504,6 @@ function h$quotRemWord32(n,d) {
RETURN_UBX_TUP2((q + (c ? 1 : 0)) >>> 0, (r - (c ? d : 0)) >>> 0);
}
-#define UN(x) ((x)>>>0)
-
function h$quotRem2Word32(nh,nl,d) {
// from Hacker's Delight book (p196)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e85fbdbf42d7447959cfa2730ab7bcfabd6b8900...f10b4f791b1d7eac78223003e1bf57ab85563cd1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e85fbdbf42d7447959cfa2730ab7bcfabd6b8900...f10b4f791b1d7eac78223003e1bf57ab85563cd1
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/20220812/1f442999/attachment-0001.html>
More information about the ghc-commits
mailing list