[Git][ghc/ghc][wip/javascript-backend] 2 commits: Fix CPP
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Tue Nov 15 09:00:43 UTC 2022
Sylvain Henry pushed to branch wip/javascript-backend at Glasgow Haskell Compiler / GHC
Commits:
54221115 by Sylvain Henry at 2022-11-15T09:26:17+01:00
Fix CPP
- - - - -
52f4ee8d by Sylvain Henry at 2022-11-15T09:59:19+01:00
Fix after Constraint-vs-Type patch
- - - - -
8 changed files:
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/StgToJS/Expr.hs
- libraries/base/GHC/Conc/Windows.hs
- libraries/base/GHC/Event.hs
- libraries/base/GHC/Event/Thread.hs
- libraries/base/GHC/Event/TimerManager.hs
- libraries/base/GHC/JS/Prim.hs
- libraries/base/System/Posix/Internals.hs
Changes:
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -291,7 +291,7 @@ dsJsFExportDynamic id co0 cconv = do
stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
export_ty = mkVisFunTyMany stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
- stbl_value <- newSysLocalDs Many stable_ptr_ty
+ stbl_value <- newSysLocalDs ManyTy stable_ptr_ty
(h_code, c_code, typestring, args_size) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True
let
{-
@@ -366,7 +366,7 @@ dsJsCall fn_id co (CCall (CCallSpec target cconv safety)) _mDeclHeader = do
tvs = map binderVar tv_bndrs
the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
- work_id = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty
+ work_id = mkSysLocal (fsLit "$wccall") work_uniq ManyTy worker_ty
-- Build the wrapper
work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
@@ -434,8 +434,8 @@ unboxJsArg arg
-- Data types with a single constructor, which has a single, primitive-typed arg
-- This deals with Int, Float etc; also Ptr, ForeignPtr
| is_product_type && data_con_arity == 1
- = do case_bndr <- newSysLocalDs Many arg_ty
- prim_arg <- newSysLocalDs Many (scaledThing data_con_arg_ty1)
+ = do case_bndr <- newSysLocalDs ManyTy arg_ty
+ prim_arg <- newSysLocalDs ManyTy (scaledThing data_con_arg_ty1)
return (Var prim_arg,
\ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body]
)
@@ -449,7 +449,7 @@ unboxJsArg arg
isJust maybe_arg3_tycon &&
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
- = do case_bndr <- newSysLocalDs Many arg_ty
+ = do case_bndr <- newSysLocalDs ManyTy arg_ty
vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
return (Var arr_cts_var,
\ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body]
@@ -497,16 +497,11 @@ boxJsResult result_ty
-- The result is IO t, so wrap the result in an IO constructor
= do { res <- jsResultWrapper io_res_ty
; let return_result state ans
- = mkCoreUbxTup
- [realWorldStatePrimTy, io_res_ty]
- [state, ans]
-{- = mkConApp (tupleDataCon Unboxed 2)
- (map Type [realWorldStatePrimTy, io_res_ty]
- ++ [state, ans]) -}
+ = mkCoreUnboxedTuple [state, ans]
; (ccall_res_ty, the_alt) <- mk_alt return_result res
- ; state_id <- newSysLocalDs Many realWorldStatePrimTy
+ ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = dataConWrapId io_data_con
@@ -541,7 +536,7 @@ mk_alt :: (Expr Var -> Expr Var -> Expr Var)
-> DsM (Type, CoreAlt)
mk_alt return_result (Nothing, wrap_result)
= do -- The ccall returns ()
- state_id <- newSysLocalDs Many realWorldStatePrimTy
+ state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
(wrap_result $ panic "jsBoxResult")
@@ -555,11 +550,10 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
let
Just ls = fmap dropRuntimeRepArgs (tyConAppArgs_maybe prim_res_ty)
arity = 1 + length ls
- args_ids {-@(result_id:as)-} <- mapM (newSysLocalDs Many) ls
- state_id <- newSysLocalDs Many realWorldStatePrimTy
+ args_ids <- mapM (newSysLocalDs ManyTy) ls
+ state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
let
- result_tup = -- mkCoreConApps (tupleDataCon Unboxed (length ls)) (map Type ls ++ map Var args_ids)
- mkCoreUbxTup ls (map Var args_ids)
+ result_tup = mkCoreUnboxedTuple (map Var args_ids)
the_rhs = return_result (Var state_id)
(wrap_result result_tup)
ccall_res_ty = mkTupleTy Unboxed (realWorldStatePrimTy : ls)
@@ -569,8 +563,8 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
return (ccall_res_ty, the_alt)
| otherwise = do
- result_id <- newSysLocalDs Many prim_res_ty
- state_id <- newSysLocalDs Many realWorldStatePrimTy
+ result_id <- newSysLocalDs ManyTy prim_res_ty
+ state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id))
@@ -597,14 +591,13 @@ jsResultWrapper result_ty
, isUnboxedTupleTyCon tc {- && False -} = do
let args' = dropRuntimeRepArgs args
(tys, wrappers) <- unzip <$> mapM jsResultWrapper args'
- matched <- mapM (mapM (newSysLocalDs Many)) tys
+ matched <- mapM (mapM (newSysLocalDs ManyTy)) tys
let tys' = catMaybes tys
-- arity = length args'
-- resCon = tupleDataCon Unboxed (length args)
err = panic "jsResultWrapper: used Id with result type Nothing"
resWrap :: CoreExpr
- resWrap = mkCoreUbxTup args' (zipWith (\w -> w . Var . fromMaybe err) wrappers matched)
- -- mkCoreConApps resCon (map Type args ++ zipWith (\w -> w . Var . fromMaybe err) wrappers matched)
+ resWrap = mkCoreUnboxedTuple (zipWith (\w -> w . Var . fromMaybe err) wrappers matched)
return $
if null tys'
then (Nothing, \_ -> resWrap)
@@ -629,7 +622,7 @@ jsResultWrapper result_ty
let args' = dropRuntimeRepArgs args
innerTy = mkTupleTy Unboxed args'
(inner_res, w) <- jsResultWrapper innerTy
- matched <- mapM (newSysLocalDs Many) args'
+ matched <- mapM (newSysLocalDs ManyTy) args'
let inner e = mkWildCase (w e) (unrestricted innerTy) result_ty
[ Alt (DataAlt (tupleDataCon Unboxed (length args')))
matched
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -367,7 +367,7 @@ resultSize args i = result
trim_args t 0 = typePrimRep t
trim_args t n
- | Just (_mult, arg, res) <- splitFunTy_maybe t
+ | Just (_af, _mult, arg, res) <- splitFunTy_maybe t
, nargs <- length (typePrimRepArgs arg)
, assert (n >= nargs) True
= trim_args (unwrapType res) (n - nargs)
=====================================
libraries/base/GHC/Conc/Windows.hs
=====================================
@@ -19,7 +19,7 @@
-- #not-home
module GHC.Conc.Windows
-#ifdef js_HOST_ARCH
+#if defined(js_HOST_ARCH)
() where
#else
( ensureIOManagerIsRunning
=====================================
libraries/base/GHC/Event.hs
=====================================
@@ -11,7 +11,7 @@
-- ----------------------------------------------------------------------------
module GHC.Event
-#ifdef js_HOST_ARCH
+#if defined(js_HOST_ARCH)
( ) where
#else
( -- * Types
=====================================
libraries/base/GHC/Event/Thread.hs
=====================================
@@ -1,10 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE BangPatterns, NoImplicitPrelude #-}
-{-# LANGUAGE CPP #-}
+
+#include <ghcplatform.h>
module GHC.Event.Thread
-#ifdef js_HOST_ARCH
+#if defined(js_HOST_ARCH)
( ) where
#else
( getSystemEventManager
@@ -21,7 +22,6 @@ module GHC.Event.Thread
, blockedOnBadFD -- used by RTS
) where
-#include <ghcplatform.h>
-- TODO: Use new Windows I/O manager
import Control.Exception (finally, SomeException, toException)
=====================================
libraries/base/GHC/Event/TimerManager.hs
=====================================
@@ -7,7 +7,7 @@
-- TODO: use the new Windows IO manager
module GHC.Event.TimerManager
-#ifdef js_HOST_ARCH
+#if defined(js_HOST_ARCH)
() where
#else
( -- * Types
=====================================
libraries/base/GHC/JS/Prim.hs
=====================================
@@ -1,14 +1,16 @@
-{-# LANGUAGE MagicHash, DeriveDataTypeable, ScopedTypeVariables, CPP #-}
-{-# LANGUAGE JavaScriptFFI,
- GHCForeignImportPrim,
- UnliftedFFITypes,
- UnboxedTuples
- #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE JavaScriptFFI #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE UnboxedTuples #-}
module GHC.JS.Prim ( JSVal(..), JSVal#
, JSException(..)
, WouldBlockException(..)
-#ifdef js_HOST_ARCH
+#if defined(js_HOST_ARCH)
, toIO
, resolve
, resolveIO
@@ -52,7 +54,7 @@ import GHC.IO
argument or result.
-}
-#ifdef js_HOST_ARCH
+#if defined(js_HOST_ARCH)
data JSVal = JSVal ByteArray#
type JSVal# = ByteArray#
#else
@@ -73,8 +75,7 @@ instance Ex.Exception JSException
instance Show JSException where
show (JSException _ xs) = "JavaScript exception: " ++ xs
--- FIXME: Luite (2022,05): appropriate CPP conditionals
-#ifdef js_HOST_ARCH
+#if defined(js_HOST_ARCH)
{-# NOINLINE toIO #-}
toIO :: Exts.Any -> IO Exts.Any
=====================================
libraries/base/System/Posix/Internals.hs
=====================================
@@ -445,7 +445,7 @@ foreign import ccall unsafe "HsBase.h __hscore_lstat"
#endif
-#ifdef js_HOST_ARCH
+#if defined(js_HOST_ARCH)
foreign import javascript unsafe "(() => { return rts_isThreaded; })" rtsIsThreaded_ :: Int
foreign import javascript interruptible "(($1_1, $2_2, $2, $c) => { return h$base_access($1_1,$2_2,$2,$c); })"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ed531a5c3cebc77544e569076e53a8706f84f47a...52f4ee8da6b65905e6e20be123997f06a8f80b85
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ed531a5c3cebc77544e569076e53a8706f84f47a...52f4ee8da6b65905e6e20be123997f06a8f80b85
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/20221115/1842ddde/attachment-0001.html>
More information about the ghc-commits
mailing list