[Git][ghc/ghc][master] 4 commits: JS: cleanup utils (#23314)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Jul 7 06:40:05 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7e759914 by Sylvain Henry at 2023-07-07T02:39:38-04:00
JS: cleanup utils (#23314)
- Removed unused code
- Don't export unused functions
- Move toTypeList to Closure module
- - - - -
f617655c by Sylvain Henry at 2023-07-07T02:39:38-04:00
JS: rename VarType/Vt into JSRep
- - - - -
19216ca5 by Sylvain Henry at 2023-07-07T02:39:38-04:00
JS: remove custom PrimRep conversion (#23314)
We use the usual conversion to PrimRep and then we convert these
PrimReps to JSReps.
- - - - -
d3de8668 by Sylvain Henry at 2023-07-07T02:39:38-04:00
JS: don't use isRuntimeRepKindedTy in JS FFI
- - - - -
10 changed files:
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Arg.hs
- compiler/GHC/StgToJS/Closure.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/FFI.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Types.hs
- compiler/GHC/StgToJS/Utils.hs
Changes:
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -471,10 +471,6 @@ unboxJsArg arg
Just arg3_tycon = maybe_arg3_tycon
-boxJsResult :: Type
- -> DsM (Type, CoreExpr -> CoreExpr)
-boxJsResult result_ty
- | isRuntimeRepKindedTy result_ty = panic "boxJsResult: runtime rep ty" -- fixme
-- Takes the result of the user-level ccall:
-- either (IO t),
-- or maybe just t for an side-effect-free call
@@ -485,7 +481,7 @@ boxJsResult result_ty
-- where t' is the unwrapped form of t. If t is simply (), then
-- the result type will be
-- State# RealWorld -> (# State# RealWorld #)
-
+boxJsResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
boxJsResult result_ty
| Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
-- isIOType_maybe handles the case where the type is a
@@ -585,7 +581,6 @@ jsResultWrapper
-- E.g. foreign import foo :: Int -> IO T
-- Then resultWrapper deals with marshalling the 'T' part
jsResultWrapper result_ty
- | isRuntimeRepKindedTy result_ty = return (Nothing, id) -- fixme this seems like a hack
-- Base case 1a: unboxed tuples
| Just (tc, args) <- splitTyConApp_maybe result_ty
, isUnboxedTupleTyCon tc {- && False -} = do
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -153,7 +153,7 @@ genApp ctx i args
-- object representation
-- - returns the object directly, otherwise
| [] <- args
- , [vt] <- idVt i
+ , [vt] <- idJSRep i
, isUnboxable vt
, ctxIsEvaluated ctx i
= do
=====================================
compiler/GHC/StgToJS/Arg.hs
=====================================
@@ -118,7 +118,7 @@ genStaticArg a = case a of
Nothing -> reg
Just expr -> unfloated expr
where
- r = uTypeVt . stgArgType $ a
+ r = unaryTypeJSRep . stgArgType $ a
reg
| isVoid r =
return []
@@ -159,8 +159,8 @@ genArg a = case a of
where
-- if our argument is a joinid, it can be an unboxed tuple
- r :: HasDebugCallStack => VarType
- r = uTypeVt . stgArgType $ a
+ r :: HasDebugCallStack => JSRep
+ r = unaryTypeJSRep . stgArgType $ a
unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr]
unfloated = \case
@@ -187,7 +187,7 @@ genIdArgI i
| isMultiVar r = mapM (identForIdN i) [1..varSize r]
| otherwise = (:[]) <$> identForId i
where
- r = uTypeVt . idType $ i
+ r = unaryTypeJSRep . idType $ i
-- | Generate IDs for stack arguments. See 'StgToJS.Expr.loadRetArgs' for use case
genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)]
=====================================
compiler/GHC/StgToJS/Closure.hs
=====================================
@@ -77,8 +77,9 @@ setObjInfoL debug obj rs layout t n a
CILayoutFixed sz _ -> sz
field_types = case layout of
CILayoutVariable -> []
- CILayoutUnknown size -> toTypeList (replicate size ObjV)
- CILayoutFixed _ fs -> toTypeList fs
+ CILayoutUnknown size -> to_type_list (replicate size ObjV)
+ CILayoutFixed _ fs -> to_type_list fs
+ to_type_list = concatMap (\x -> replicate (varSize x) (fromEnum x))
setObjInfo :: Bool -- ^ debug: output all symbol names
-> Ident -- ^ the thing to modify
@@ -241,3 +242,4 @@ varName :: Int -> Ident
varName i
| i < 0 || i > jsClosureCount = TxtI $ mkFastString ('x' : show i)
| otherwise = varCache ! i
+
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -304,7 +304,7 @@ genSetConInfo i d l {- srt -} = do
emitClosureInfo $ ClosureInfo ei
(CIRegs 0 [PtrV])
(mkFastString $ renderWithContext defaultSDocContext (ppr d))
- (fixedLayout $ map uTypeVt fields)
+ (fixedLayout $ map unaryTypeJSRep fields)
(CICon $ dataConTag d)
sr
return (mkDataEntry ei)
@@ -350,8 +350,8 @@ genToplevelRhs i rhs = case rhs of
r <- updateThunk
pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r)
else return (StaticFun eidt (map StaticObjArg lidents'),
- (if null lidents then CIRegs 1 (concatMap idVt args)
- else CIRegs 0 (PtrV : concatMap idVt args))
+ (if null lidents then CIRegs 1 (concatMap idJSRep args)
+ else CIRegs 0 (PtrV : concatMap idJSRep args))
, mempty)
setcc <- ifProfiling $
if et == CIThunk
@@ -360,7 +360,7 @@ genToplevelRhs i rhs = case rhs of
emitClosureInfo (ClosureInfo eid
regs
idt
- (fixedLayout $ map (uTypeVt . idType) lids)
+ (fixedLayout $ map (unaryTypeJSRep . idType) lids)
et
sr)
ccId <- costCentreStackLbl cc
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -241,7 +241,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) =
let f = (bh <> lvs <> body)
emitClosureInfo $
ClosureInfo ei
- (CIRegs 0 $ concatMap idVt args)
+ (CIRegs 0 $ concatMap idJSRep args)
(eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)))
(fixedLayout . reverse $
map (stackSlotType . fst) (ctxLneFrameVars ctx))
@@ -275,9 +275,9 @@ genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body typ) =
else enterCostCentreFun cc
sr <- genStaticRefsRhs rhs
emitClosureInfo $ ClosureInfo ei
- (CIRegs 0 $ PtrV : concatMap idVt args)
+ (CIRegs 0 $ PtrV : concatMap idJSRep args)
(eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)))
- (fixedLayout $ map (uTypeVt . idType) live)
+ (fixedLayout $ map (unaryTypeJSRep . idType) live)
et
sr
emitToplevel (jFunction ei [] (mconcat [ll, llv, upd, setcc, body]))
@@ -285,15 +285,12 @@ genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body typ) =
entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx)
-- | Generate the entry function types for identifiers. Note that this only
--- returns either 'CIThunk' or 'CIFun'. Everything else (PAP Blackhole etc.) is
--- filtered as not a RuntimeRepKinded type.
+-- returns either 'CIThunk' or 'CIFun'.
genEntryType :: HasDebugCallStack => [Id] -> G CIType
genEntryType [] = return CIThunk
-genEntryType args0 = do
+genEntryType args = do
args' <- mapM genIdArg args
return $ CIFun (length args) (length $ concat args')
- where
- args = filter (not . isRuntimeRepKindedTy . idType) args0
-- | Generate the body of an object
genBody :: HasDebugCallStack
@@ -373,7 +370,7 @@ verifyRuntimeReps xs = do
where
verifyRuntimeRep i = do
i' <- varsForId i
- pure $ go i' (idVt i)
+ pure $ go i' (idJSRep i)
go js (VoidV:vs) = go js vs
go (j1:j2:js) (LongV:vs) = v "h$verify_rep_long" [j1,j2] <> go js vs
go (j1:j2:js) (AddrV:vs) = v "h$verify_rep_addr" [j1,j2] <> go js vs
@@ -491,11 +488,11 @@ optimizeFree
-- -- Bool: True when the slot already contains a value
optimizeFree offset ids = do
-- this line goes wrong vvvvvvv
- let -- ids' = concat $ map (\i -> map (i,) [1..varSize . uTypeVt . idType $ i]) ids
+ let -- ids' = concat $ map (\i -> map (i,) [1..varSize . unaryTypeJSRep . idType $ i]) ids
idSize :: Id -> Int
- idSize i = sum $ map varSize (typeVt . idType $ i)
+ idSize i = sum $ map varSize (typeJSRep . idType $ i)
ids' = concatMap (\i -> map (i,) [1..idSize i]) ids
- -- 1..varSize] . uTypeVt . idType $ i]) (typeVt ids)
+ -- 1..varSize] . unaryTypeJSRep . idType $ i]) (typeJSRep ids)
l = length ids'
slots <- drop offset . take l . (++repeat SlotUnknown) <$> getSlots
let slm = M.fromList (zip slots [0..])
@@ -630,10 +627,10 @@ genRet ctx e at as l = freshIdent >>= f
return (pushLne <> saveCCS <> pushRet)
fst3 ~(x,_,_) = x
- altRegs :: HasDebugCallStack => [VarType]
+ altRegs :: HasDebugCallStack => [JSRep]
altRegs = case at of
- PrimAlt ptc -> [primRepVt ptc]
- MultiValAlt _n -> idVt e
+ PrimAlt ptc -> [primRepToJSRep ptc]
+ MultiValAlt _n -> idJSRep e
_ -> [PtrV]
-- special case for popping CCS but preserving stack size
@@ -690,7 +687,7 @@ genAlts ctx e at me alts = do
-> do
ie <- varsForId e
(r, bss) <- normalizeBranches ctx <$>
- mapM (isolateSlots . mkPrimIfBranch ctx [primRepVt tc]) alts
+ mapM (isolateSlots . mkPrimIfBranch ctx [primRepToJSRep tc]) alts
setSlots []
return (mkSw ie bss, r)
@@ -877,7 +874,7 @@ mkAlgBranch top d alt
-- | Generate a primitive If-expression
mkPrimIfBranch :: ExprCtx
- -> [VarType]
+ -> [JSRep]
-> CgStgAlt
-> G (Branch (Maybe [JExpr]))
mkPrimIfBranch top _vt alt =
=====================================
compiler/GHC/StgToJS/FFI.hs
=====================================
@@ -175,7 +175,7 @@ genFFIArg isJavaScriptCc a@(StgVarArg i)
where
tycon = tyConAppTyCon (unwrapType arg_ty)
arg_ty = stgArgType a
- r = uTypeVt arg_ty
+ r = unaryTypeJSRep arg_ty
saturateFFI :: Int -> JStat -> Sat.JStat
saturateFFI u = satJStat (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u)
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -509,7 +509,7 @@ instance Binary JSFFIType where
put_ bh = putEnum bh
get bh = getEnum bh
-instance Binary VarType where
+instance Binary JSRep where
put_ bh = putEnum bh
get bh = getEnum bh
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -110,7 +110,7 @@ data ClosureInfo = ClosureInfo
data CIRegs
= CIRegsUnknown -- ^ A value witnessing a state of unknown registers
| CIRegs { ciRegsSkip :: Int -- ^ unused registers before actual args start
- , ciRegsTypes :: [VarType] -- ^ args
+ , ciRegsTypes :: [JSRep] -- ^ args
}
deriving stock (Eq, Ord, Show)
@@ -122,7 +122,7 @@ data CILayout
}
| CILayoutFixed -- ^ whole layout known
{ layoutSize :: !Int -- ^ closure size in array positions, including entry
- , layout :: [VarType] -- ^ The set of sized Types to layout
+ , layout :: [JSRep] -- ^ The list of JSReps to layout
}
deriving stock (Eq, Ord, Show)
@@ -149,8 +149,8 @@ instance ToJExpr CIStatic where
toJExpr (CIStaticRefs []) = null_ -- [je| null |]
toJExpr (CIStaticRefs rs) = toJExpr (map TxtI rs)
--- | Free variable types
-data VarType
+-- | JS primitive representations
+data JSRep
= PtrV -- ^ pointer = reference to heap object (closure object), lifted or not.
-- Can also be some RTS object (e.g. TVar#, MVar#, MutVar#, Weak#)
| VoidV -- ^ no fields
@@ -162,7 +162,7 @@ data VarType
| ArrV -- ^ boxed array
deriving stock (Eq, Ord, Enum, Bounded, Show)
-instance ToJExpr VarType where
+instance ToJExpr JSRep where
toJExpr = toJExpr . fromEnum
-- | The type of identifiers. These determine the suffix of generated functions
=====================================
compiler/GHC/StgToJS/Utils.hs
=====================================
@@ -2,76 +2,44 @@
{-# LANGUAGE LambdaCase #-}
module GHC.StgToJS.Utils
- ( assignToTypedExprs
- , assignCoerce1
+ ( assignCoerce1
, assignToExprCtx
- -- * Core Utils
+ , fixedLayout
+ , assocIdExprs
+ -- * Unboxable datacon
, isUnboxableCon
, isUnboxable
- , SlotCount(..)
+ , isBoolDataCon
+ -- * JSRep
, slotCount
, varSize
- , varSlotCount
, typeSize
, isVoid
- , isPtr
- , isSingleVar
, isMultiVar
- , isMatchable
- , tyConVt
- , idVt
- , typeVt
- , uTypeVt
- , primRepVt
- , typePrimRep'
- , tyConPrimRep'
- , kindPrimRep'
- , primTypeVt
- , argVt
- , dataConType
- , isBoolDataCon
- , fixedLayout
+ , idJSRep
+ , typeJSRep
+ , unaryTypeJSRep
+ , primRepToJSRep
, stackSlotType
- , idPrimReps
- , typePrimReps
, primRepSize
- , assocPrimReps
- , assocIdPrimReps
- , assocIdExprs
, mkArityTag
- , toTypeList
- -- * Stg Utils
- , bindingRefs
- , rhsRefs
+ -- * References and Ids
, exprRefs
- , altRefs
- , argRefs
, hasExport
, collectTopIds
, collectIds
- , removeTick
+ -- * Live variables
, LiveVars
, liveStatic
, liveVars
- , stgTopBindLive
- , stgBindLive
- , stgBindRhsLive
, stgRhsLive
- , stgArgLive
, stgExprLive
- , stgAltLive
- , stgLetNoEscapeLive
- , bindees
, isUpdatableRhs
- , stgLneLive
, stgLneLive'
, stgLneLiveExpr
, isInlineExpr
- , inspectInlineBinding
- , inspectInlineRhs
- , isInlineForeignCall
- , isInlineApp
- ) where
+ )
+where
import GHC.Prelude
@@ -91,8 +59,6 @@ import GHC.Stg.Syntax
import GHC.Tc.Utils.TcType
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline)
@@ -163,7 +129,7 @@ assignCoerce p1 p2 = assignTypedExprs [p1] [p2]
isUnboxableCon :: DataCon -> Bool
isUnboxableCon dc
| [t] <- dataConRepArgTys dc
- , [t1] <- typeVt (scaledThing t)
+ , [t1] <- typeJSRep (scaledThing t)
= isUnboxable t1 &&
dataConTag dc == 1 &&
length (tyConDataCons $ dataConTyCon dc) == 1
@@ -171,7 +137,7 @@ isUnboxableCon dc
-- | one-constructor types with one primitive field represented as a JS Number
-- can be unboxed
-isUnboxable :: VarType -> Bool
+isUnboxable :: JSRep -> Bool
isUnboxable DoubleV = True
isUnboxable IntV = True -- includes Char#
isUnboxable _ = False
@@ -194,153 +160,56 @@ slotCount = \case
TwoSlots -> 2
--- | Number of slots occupied by a value with the given VarType
-varSize :: VarType -> Int
-varSize = slotCount . varSlotCount
+-- | Number of slots occupied by a value with the given JSRep
+varSize :: JSRep -> Int
+varSize = slotCount . jsRepSlots
-varSlotCount :: VarType -> SlotCount
-varSlotCount VoidV = NoSlot
-varSlotCount LongV = TwoSlots -- hi, low
-varSlotCount AddrV = TwoSlots -- obj/array, offset
-varSlotCount _ = OneSlot
+jsRepSlots :: JSRep -> SlotCount
+jsRepSlots VoidV = NoSlot
+jsRepSlots LongV = TwoSlots -- hi, low
+jsRepSlots AddrV = TwoSlots -- obj/array, offset
+jsRepSlots _ = OneSlot
typeSize :: Type -> Int
-typeSize t = sum . map varSize . typeVt $ t
+typeSize t = sum . map varSize . typeJSRep $ t
-isVoid :: VarType -> Bool
+isVoid :: JSRep -> Bool
isVoid VoidV = True
isVoid _ = False
-isPtr :: VarType -> Bool
-isPtr PtrV = True
-isPtr _ = False
-
-isSingleVar :: VarType -> Bool
-isSingleVar v = varSlotCount v == OneSlot
-
-isMultiVar :: VarType -> Bool
-isMultiVar v = case varSlotCount v of
+isMultiVar :: JSRep -> Bool
+isMultiVar v = case jsRepSlots v of
NoSlot -> False
OneSlot -> False
TwoSlots -> True
--- | can we pattern match on these values in a case?
-isMatchable :: [VarType] -> Bool
-isMatchable [DoubleV] = True
-isMatchable [IntV] = True
-isMatchable _ = False
+idJSRep :: HasDebugCallStack => Id -> [JSRep]
+idJSRep = typeJSRep . idType
-tyConVt :: HasDebugCallStack => TyCon -> [VarType]
-tyConVt = typeVt . mkTyConTy
-
-idVt :: HasDebugCallStack => Id -> [VarType]
-idVt = typeVt . idType
-
-typeVt :: HasDebugCallStack => Type -> [VarType]
-typeVt t | isRuntimeRepKindedTy t = []
-typeVt t = map primRepVt (typePrimRep t)-- map uTypeVt (repTypeArgs t)
+typeJSRep :: HasDebugCallStack => Type -> [JSRep]
+typeJSRep t = map primRepToJSRep (typePrimRep t)
-- only use if you know it's not an unboxed tuple
-uTypeVt :: HasDebugCallStack => UnaryType -> VarType
-uTypeVt ut
- | isRuntimeRepKindedTy ut = VoidV
--- | isRuntimeRepTy ut = VoidV
- -- GHC panics on this otherwise
- | Just (tc, ty_args) <- splitTyConApp_maybe ut
- , length ty_args /= tyConArity tc = PtrV
- | isPrimitiveType ut = (primTypeVt ut)
- | otherwise =
- case typePrimRep' ut of
- [] -> VoidV
- [pt] -> primRepVt pt
- _ -> pprPanic "uTypeVt: not unary" (ppr ut)
-
-primRepVt :: HasDebugCallStack => PrimRep -> VarType
-primRepVt VoidRep = VoidV
-primRepVt (BoxedRep _) = PtrV -- fixme does ByteArray# ever map to this?
-primRepVt IntRep = IntV
-primRepVt Int8Rep = IntV
-primRepVt Int16Rep = IntV
-primRepVt Int32Rep = IntV
-primRepVt WordRep = IntV
-primRepVt Word8Rep = IntV
-primRepVt Word16Rep = IntV
-primRepVt Word32Rep = IntV
-primRepVt Int64Rep = LongV
-primRepVt Word64Rep = LongV
-primRepVt AddrRep = AddrV
-primRepVt FloatRep = DoubleV
-primRepVt DoubleRep = DoubleV
-primRepVt (VecRep{}) = error "uTypeVt: vector types are unsupported"
-
-typePrimRep' :: HasDebugCallStack => UnaryType -> [PrimRep]
-typePrimRep' ty = kindPrimRep' empty (typeKind ty)
-
--- | Find the primitive representation of a 'TyCon'. Defined here to
--- avoid module loops. Call this only on unlifted tycons.
-tyConPrimRep' :: HasDebugCallStack => TyCon -> [PrimRep]
-tyConPrimRep' tc = kindPrimRep' empty res_kind
- where
- res_kind = tyConResKind tc
-
--- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's
--- of values of types of this kind.
-kindPrimRep' :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
-kindPrimRep' doc ki
- | Just ki' <- coreView ki
- = kindPrimRep' doc ki'
-kindPrimRep' doc (TyConApp _typ [runtime_rep])
- = -- ASSERT( typ `hasKey` tYPETyConKey )
- runtimeRepPrimRep doc runtime_rep
-kindPrimRep' doc ki
- = pprPanic "kindPrimRep'" (ppr ki $$ doc)
-
-primTypeVt :: HasDebugCallStack => Type -> VarType
-primTypeVt t = case tyConAppTyCon_maybe (unwrapType t) of
- Nothing -> error "primTypeVt: not a TyCon"
- Just tc
- | tc == charPrimTyCon -> IntV
- | tc == intPrimTyCon -> IntV
- | tc == wordPrimTyCon -> IntV
- | tc == floatPrimTyCon -> DoubleV
- | tc == doublePrimTyCon -> DoubleV
- | tc == int8PrimTyCon -> IntV
- | tc == word8PrimTyCon -> IntV
- | tc == int16PrimTyCon -> IntV
- | tc == word16PrimTyCon -> IntV
- | tc == int32PrimTyCon -> IntV
- | tc == word32PrimTyCon -> IntV
- | tc == int64PrimTyCon -> LongV
- | tc == word64PrimTyCon -> LongV
- | tc == addrPrimTyCon -> AddrV
- | tc == stablePtrPrimTyCon -> AddrV
- | tc == stableNamePrimTyCon -> PtrV
- | tc == statePrimTyCon -> VoidV
- | tc == proxyPrimTyCon -> VoidV
- | tc == realWorldTyCon -> VoidV
- | tc == threadIdPrimTyCon -> PtrV
- | tc == weakPrimTyCon -> PtrV
- | tc == arrayPrimTyCon -> ArrV
- | tc == smallArrayPrimTyCon -> ArrV
- | tc == byteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal
- | tc == mutableArrayPrimTyCon -> ArrV
- | tc == smallMutableArrayPrimTyCon -> ArrV
- | tc == mutableByteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal
- | tc == mutVarPrimTyCon -> PtrV
- | tc == mVarPrimTyCon -> PtrV
- | tc == tVarPrimTyCon -> PtrV
- | tc == bcoPrimTyCon -> PtrV -- unsupported?
- | tc == stackSnapshotPrimTyCon -> PtrV
- | tc == ioPortPrimTyCon -> PtrV -- unsupported?
- | tc == anyTyCon -> PtrV
- | tc == compactPrimTyCon -> PtrV -- unsupported?
- | tc == eqPrimTyCon -> VoidV -- coercion token?
- | tc == eqReprPrimTyCon -> VoidV -- role
- | tc == unboxedUnitTyCon -> VoidV -- Void#
- | otherwise -> PtrV -- anything else must be some boxed thing
-
-argVt :: StgArg -> VarType
-argVt a = uTypeVt . stgArgType $ a
+unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep
+unaryTypeJSRep ut = primRepToJSRep (typePrimRep1 ut)
+
+primRepToJSRep :: HasDebugCallStack => PrimRep -> JSRep
+primRepToJSRep VoidRep = VoidV
+primRepToJSRep (BoxedRep _) = PtrV
+primRepToJSRep IntRep = IntV
+primRepToJSRep Int8Rep = IntV
+primRepToJSRep Int16Rep = IntV
+primRepToJSRep Int32Rep = IntV
+primRepToJSRep WordRep = IntV
+primRepToJSRep Word8Rep = IntV
+primRepToJSRep Word16Rep = IntV
+primRepToJSRep Word32Rep = IntV
+primRepToJSRep Int64Rep = LongV
+primRepToJSRep Word64Rep = LongV
+primRepToJSRep AddrRep = AddrV
+primRepToJSRep FloatRep = DoubleV
+primRepToJSRep DoubleRep = DoubleV
+primRepToJSRep (VecRep{}) = error "primRepToJSRep: vector types are unsupported"
dataConType :: DataCon -> Type
dataConType dc = idType (dataConWrapId dc)
@@ -350,16 +219,16 @@ isBoolDataCon dc = isBoolTy (dataConType dc)
-- standard fixed layout: payload types
-- payload starts at .d1 for heap objects, entry closest to Sp for stack frames
-fixedLayout :: [VarType] -> CILayout
+fixedLayout :: [JSRep] -> CILayout
fixedLayout vts = CILayoutFixed (sum (map varSize vts)) vts
-- 2-var values might have been moved around separately, use DoubleV as substitute
-- ObjV is 1 var, so this is no problem for implicit metadata
-stackSlotType :: Id -> VarType
+stackSlotType :: Id -> JSRep
stackSlotType i
- | OneSlot <- varSlotCount otype = otype
- | otherwise = DoubleV
- where otype = uTypeVt (idType i)
+ | OneSlot <- jsRepSlots otype = otype
+ | otherwise = DoubleV
+ where otype = unaryTypeJSRep (idType i)
idPrimReps :: Id -> [PrimRep]
idPrimReps = typePrimReps . idType
@@ -368,7 +237,7 @@ typePrimReps :: Type -> [PrimRep]
typePrimReps = typePrimRep . unwrapType
primRepSize :: PrimRep -> SlotCount
-primRepSize p = varSlotCount (primRepVt p)
+primRepSize p = jsRepSlots (primRepToJSRep p)
-- | Associate the given values to each RrimRep in the given order, taking into
-- account the number of slots per PrimRep
@@ -393,9 +262,6 @@ assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es)
mkArityTag :: Int -> Int -> Int
mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8)
-toTypeList :: [VarType] -> [Int]
-toTypeList = concatMap (\x -> replicate (varSize x) (fromEnum x))
-
--------------------------------------------------------------------------------
-- Stg Utils
--------------------------------------------------------------------------------
@@ -467,10 +333,6 @@ collectIds unfloated b =
| Just m <- nameModule_maybe (getName i) = m == gHC_PRIM
| otherwise = False
-removeTick :: CgStgExpr -> CgStgExpr
-removeTick (StgTick _ e) = e
-removeTick e = e
-
-----------------------------------------------------
-- Live vars
--
@@ -484,11 +346,6 @@ liveStatic = filterDVarSet isGlobalId
liveVars :: LiveVars -> LiveVars
liveVars = filterDVarSet (not . isGlobalId)
-stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)]
-stgTopBindLive = \case
- StgTopLifted b -> stgBindLive b
- StgTopStringLit {} -> []
-
stgBindLive :: CgStgBinding -> [(Id, LiveVars)]
stgBindLive = \case
StgNonRec b rhs -> [(b, stgRhsLive rhs)]
@@ -529,9 +386,6 @@ stgAltLive :: CgStgAlt -> LiveVars
stgAltLive alt =
delDVarSetList (stgExprLive True (alt_rhs alt)) (alt_bndrs alt)
-stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars
-stgLetNoEscapeLive _someBool _b _e = panic "stgLetNoEscapeLive"
-
bindees :: CgStgBinding -> [Id]
bindees = \case
StgNonRec b _e -> [b]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74a4dd2ec6e200b11a56b6f82907feb66e94c90b...d3de8668aea2209fefbfcf8704c38fe73300a99b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74a4dd2ec6e200b11a56b6f82907feb66e94c90b...d3de8668aea2209fefbfcf8704c38fe73300a99b
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/20230707/df38a7b7/attachment-0001.html>
More information about the ghc-commits
mailing list