Commit e88bfcee authored by sof's avatar sof
Browse files

[project @ 1998-10-21 11:28:00 by sof]

- added primops for read&writing StablePtrs to ByteArrays, Adds and FOs
- egcs crashes in odd ways when encountering the typedefs we need to
  produce when compiling 'foreign import dynamic's. To workaround the
  problem, kludgily add a CCallTypedef constructor to AbsCSyn.AbstractC
  which the flattener will produce (at the toplevel) when encountering
  CCallOps inside COptStmts.
- augmented PrimOp.CCallOp to carry a unique when it represents a
  'foreign import dynamic' call. The CoreToStg pass ensures that these
  uniques are exactly that. They're used to eventuall generate (unique)
  typedef names.
parent 42b29bf9
......@@ -150,6 +150,17 @@ stored in a mixed type location.)
| CCallProfCtrMacro FAST_STRING [CAddrMode]
| CCallProfCCMacro FAST_STRING [CAddrMode]
{- The presence of this constructor is a makeshift solution;
it being used to work around a gcc-related problem of
handling typedefs within statement blocks (or, rather,
the inability to do so.)
The AbstractC flattener takes care of lifting out these
typedefs if needs be (i.e., when generating .hc code and
compiling 'foreign import dynamic's)
-}
| CCallTypedef PrimOp{-CCallOp-} [CAddrMode] [CAddrMode]
-- *** the next three [or so...] are DATA (those above are CODE) ***
| CStaticClosure
......
......@@ -32,6 +32,9 @@ import PrimRep ( getPrimRepSize, PrimRep(..) )
import Unique ( Unique{-instance Eq-} )
import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
import Util ( assocDefaultUsing, panic )
import CmdLineOpts ( opt_ProduceC )
import Maybes ( maybeToBool )
import PrimOp ( PrimOp(..) )
infixr 9 `thenFlt`
\end{code}
......@@ -444,6 +447,14 @@ flatAbsC stmt@(CInitHdr a b cc u)
= flatAmode cc `thenFlt` \ (new_cc, tops) ->
returnFlt (CInitHdr a b new_cc u, tops)
flatAbsC stmt@(COpStmt results td@(CCallOp (Right _) _ _ _ _ _) args liveness_mask vol_regs)
| maybeToBool opt_ProduceC
= flatAmodes results `thenFlt` \ (results_here, tops1) ->
flatAmodes args `thenFlt` \ (args_here, tops2) ->
let tdef = CCallTypedef td results args in
returnFlt (COpStmt results_here td args_here liveness_mask vol_regs,
mkAbsCStmts tdef (mkAbsCStmts tops1 tops2))
flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
= flatAmodes results `thenFlt` \ (results_here, tops1) ->
flatAmodes args `thenFlt` \ (args_here, tops2) ->
......
......@@ -233,6 +233,39 @@ pprAbsC stmt@(CCallProfCtrMacro op as) _
pprAbsC stmt@(CCallProfCCMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv _ _) results args) _
= hsep [ ptext SLIT("typedef")
, ccall_res_ty
, fun_nm
, parens (hsep (punctuate comma ccall_decl_ty_args))
] <> semi
where
fun_nm = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
ccall_fun_ty =
case op_str of
Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
ccall_res_ty =
case non_void_results of
[] -> ptext SLIT("void")
[amode] -> text (showPrimRep (getAmodeRep amode))
_ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
ccall_decl_ty_args = tail ccall_arg_tys
ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
-- the first argument will be the "I/O world" token (a VoidRep)
-- all others should be non-void
non_void_args =
let nvas = tail args
in ASSERT (all non_void nvas) nvas
-- there will usually be two results: a (void) state which we
-- should ignore and a (possibly void) result.
non_void_results =
let nvrs = grab_non_void_amodes results
in ASSERT (length nvrs <= 1) nvrs
pprAbsC (CCodeBlock label abs_C) _
= ASSERT( maybeToBool(nonemptyAbsC abs_C) )
......@@ -604,10 +637,10 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask
else
vcat [
char '{',
declare_fun_extern, -- declare expected function type.
declare_local_vars, -- local var for *result*
vcat local_arg_decls,
pp_save_context,
declare_fun_extern, -- declare expected function type.
process_casm local_vars pp_non_void_args casm_str,
pp_restore_context,
assign_results,
......@@ -673,7 +706,7 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask
-}
declare_fun_extern
| is_asm || not opt_EmitCExternDecls = empty
| is_dynamic || is_asm || not opt_EmitCExternDecls = empty
| otherwise =
hsep [ typedef_or_extern
, ccall_res_ty
......@@ -702,13 +735,20 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask
[amode] -> text (showPrimRep (getAmodeRep amode))
_ -> panic "pprCCall: ccall_res_ty"
ccall_fun_ty = ptext SLIT("_ccall_fun_ty")
ccall_fun_ty =
ptext SLIT("_ccall_fun_ty") <>
case op_str of
Right u -> ppr u
_ -> empty
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results pp_liveness
(Just asm_str) = op_str
is_dynamic = not (maybeToBool op_str)
(Left asm_str) = op_str
is_dynamic =
case op_str of
Left _ -> False
_ -> True
casm_str = if is_asm then _UNPK_ asm_str else ccall_str
......
......@@ -96,7 +96,7 @@ dsCCall label args may_gc is_asm io_result_ty
boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
let
the_ccall_op = CCallOp (Just label) is_asm may_gc cCallConv
the_ccall_op = CCallOp (Left label) is_asm may_gc cCallConv
(map coreExprType final_args)
final_result_ty
in
......
......@@ -116,12 +116,10 @@ dsFImport nm ty may_not_gc ext_name cconv =
(ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty
in
boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
(case ext_name of
Dynamic -> getUniqueDs `thenDs` \ u -> returnDs (Right u)
ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
let
label =
case ext_name of
Dynamic -> Nothing
ExtName fs _ -> Just fs
the_ccall_op = CCallOp label False (not may_not_gc) cconv
(map coreExprType final_args)
final_result_ty
......@@ -348,7 +346,7 @@ dsFExportDynamic i ty ext_name cconv =
Var stbl,
Lit (MachLitLit (_PK_ fe_nm) AddrRep)]
label = Just SLIT("createAdjustor")
label = Left SLIT("createAdjustor")
the_ccall_op = CCallOp label False False{-won't GC-} cCallConv
(map coreExprType ccall_args)
stateAndAddrPrimTy
......
......@@ -445,7 +445,7 @@ primCode [lhs] SeqOp [a]
-- trace "SeqOp" $
returnUs (\xs -> assign : xs)
primCode lhs (CCallOp (Just fn) is_asm may_gc cconv arg_tys result_ty) rhs
primCode lhs (CCallOp (Left fn) is_asm may_gc cconv arg_tys result_ty) rhs
| is_asm = error "ERROR: Native code generator can't handle casm"
| may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
| otherwise
......
......@@ -169,8 +169,11 @@ data PrimOp
A special ``trap-door'' to use in making calls direct to C functions:
\begin{code}
| CCallOp (Maybe FAST_STRING) -- Nothing => first argument (an Addr#) is the function pointer
-- Just fn => An "unboxed" ccall# to `fn'.
| CCallOp (Either
FAST_STRING -- Left fn => An "unboxed" ccall# to `fn'.
Unique) -- Right u => first argument (an Addr#) is the function pointer
-- (unique is used to
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
......@@ -402,90 +405,98 @@ tagOf_PrimOp (NewByteArrayOp WordRep) = ILIT(126)
tagOf_PrimOp (NewByteArrayOp AddrRep) = ILIT(127)
tagOf_PrimOp (NewByteArrayOp FloatRep) = ILIT(128)
tagOf_PrimOp (NewByteArrayOp DoubleRep) = ILIT(129)
tagOf_PrimOp SameMutableArrayOp = ILIT(130)
tagOf_PrimOp SameMutableByteArrayOp = ILIT(131)
tagOf_PrimOp ReadArrayOp = ILIT(132)
tagOf_PrimOp WriteArrayOp = ILIT(133)
tagOf_PrimOp IndexArrayOp = ILIT(134)
tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(135)
tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(136)
tagOf_PrimOp (ReadByteArrayOp WordRep) = ILIT(137)
tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(138)
tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(139)
tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(140)
tagOf_PrimOp (ReadByteArrayOp Int64Rep) = ILIT(141)
tagOf_PrimOp (ReadByteArrayOp Word64Rep) = ILIT(142)
tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(143)
tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(144)
tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(145)
tagOf_PrimOp (WriteByteArrayOp WordRep) = ILIT(146)
tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(147)
tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(148)
tagOf_PrimOp (WriteByteArrayOp Int64Rep) = ILIT(149)
tagOf_PrimOp (WriteByteArrayOp Word64Rep) = ILIT(150)
tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(151)
tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(152)
tagOf_PrimOp (IndexByteArrayOp WordRep) = ILIT(153)
tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(154)
tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(155)
tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(156)
tagOf_PrimOp (IndexByteArrayOp Int64Rep) = ILIT(157)
tagOf_PrimOp (IndexByteArrayOp Word64Rep) = ILIT(158)
tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(159)
tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(160)
tagOf_PrimOp (IndexOffAddrOp WordRep) = ILIT(161)
tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(162)
tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(163)
tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(164)
tagOf_PrimOp (IndexOffAddrOp Int64Rep) = ILIT(165)
tagOf_PrimOp (IndexOffAddrOp Word64Rep) = ILIT(166)
tagOf_PrimOp (IndexOffForeignObjOp CharRep) = ILIT(167)
tagOf_PrimOp (IndexOffForeignObjOp IntRep) = ILIT(168)
tagOf_PrimOp (IndexOffForeignObjOp WordRep) = ILIT(169)
tagOf_PrimOp (IndexOffForeignObjOp AddrRep) = ILIT(170)
tagOf_PrimOp (IndexOffForeignObjOp FloatRep) = ILIT(171)
tagOf_PrimOp (IndexOffForeignObjOp DoubleRep) = ILIT(172)
tagOf_PrimOp (IndexOffForeignObjOp Int64Rep) = ILIT(173)
tagOf_PrimOp (IndexOffForeignObjOp Word64Rep) = ILIT(174)
tagOf_PrimOp (WriteOffAddrOp CharRep) = ILIT(175)
tagOf_PrimOp (WriteOffAddrOp IntRep) = ILIT(176)
tagOf_PrimOp (WriteOffAddrOp WordRep) = ILIT(177)
tagOf_PrimOp (WriteOffAddrOp AddrRep) = ILIT(178)
tagOf_PrimOp (WriteOffAddrOp FloatRep) = ILIT(179)
tagOf_PrimOp (WriteOffAddrOp DoubleRep) = ILIT(180)
tagOf_PrimOp (WriteOffAddrOp Int64Rep) = ILIT(181)
tagOf_PrimOp (WriteOffAddrOp Word64Rep) = ILIT(182)
tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(183)
tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(184)
tagOf_PrimOp SizeofByteArrayOp = ILIT(185)
tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(186)
tagOf_PrimOp NewSynchVarOp = ILIT(187)
tagOf_PrimOp TakeMVarOp = ILIT(188)
tagOf_PrimOp PutMVarOp = ILIT(189)
tagOf_PrimOp ReadIVarOp = ILIT(190)
tagOf_PrimOp WriteIVarOp = ILIT(191)
tagOf_PrimOp MakeForeignObjOp = ILIT(192)
tagOf_PrimOp WriteForeignObjOp = ILIT(193)
tagOf_PrimOp MakeStablePtrOp = ILIT(194)
tagOf_PrimOp DeRefStablePtrOp = ILIT(195)
tagOf_PrimOp (CCallOp _ _ _ _ _ _) = ILIT(196)
tagOf_PrimOp ErrorIOPrimOp = ILIT(197)
tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(198)
tagOf_PrimOp SeqOp = ILIT(199)
tagOf_PrimOp ParOp = ILIT(200)
tagOf_PrimOp ForkOp = ILIT(201)
tagOf_PrimOp DelayOp = ILIT(202)
tagOf_PrimOp WaitReadOp = ILIT(203)
tagOf_PrimOp WaitWriteOp = ILIT(204)
tagOf_PrimOp ParGlobalOp = ILIT(205)
tagOf_PrimOp ParLocalOp = ILIT(206)
tagOf_PrimOp ParAtOp = ILIT(207)
tagOf_PrimOp ParAtAbsOp = ILIT(208)
tagOf_PrimOp ParAtRelOp = ILIT(209)
tagOf_PrimOp ParAtForNowOp = ILIT(210)
tagOf_PrimOp CopyableOp = ILIT(211)
tagOf_PrimOp NoFollowOp = ILIT(212)
tagOf_PrimOp SameMVarOp = ILIT(213)
tagOf_PrimOp (NewByteArrayOp StablePtrRep) = ILIT(130)
tagOf_PrimOp SameMutableArrayOp = ILIT(131)
tagOf_PrimOp SameMutableByteArrayOp = ILIT(132)
tagOf_PrimOp ReadArrayOp = ILIT(133)
tagOf_PrimOp WriteArrayOp = ILIT(134)
tagOf_PrimOp IndexArrayOp = ILIT(135)
tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(136)
tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(137)
tagOf_PrimOp (ReadByteArrayOp WordRep) = ILIT(138)
tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(139)
tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(140)
tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(141)
tagOf_PrimOp (ReadByteArrayOp StablePtrRep) = ILIT(142)
tagOf_PrimOp (ReadByteArrayOp Int64Rep) = ILIT(143)
tagOf_PrimOp (ReadByteArrayOp Word64Rep) = ILIT(144)
tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(145)
tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(146)
tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(147)
tagOf_PrimOp (WriteByteArrayOp WordRep) = ILIT(148)
tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(149)
tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(150)
tagOf_PrimOp (WriteByteArrayOp StablePtrRep) = ILIT(151)
tagOf_PrimOp (WriteByteArrayOp Int64Rep) = ILIT(152)
tagOf_PrimOp (WriteByteArrayOp Word64Rep) = ILIT(153)
tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(154)
tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(155)
tagOf_PrimOp (IndexByteArrayOp WordRep) = ILIT(156)
tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(157)
tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(158)
tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(159)
tagOf_PrimOp (IndexByteArrayOp StablePtrRep) = ILIT(160)
tagOf_PrimOp (IndexByteArrayOp Int64Rep) = ILIT(161)
tagOf_PrimOp (IndexByteArrayOp Word64Rep) = ILIT(162)
tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(163)
tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(164)
tagOf_PrimOp (IndexOffAddrOp WordRep) = ILIT(165)
tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(166)
tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(167)
tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(168)
tagOf_PrimOp (IndexOffAddrOp StablePtrRep) = ILIT(169)
tagOf_PrimOp (IndexOffAddrOp Int64Rep) = ILIT(170)
tagOf_PrimOp (IndexOffAddrOp Word64Rep) = ILIT(171)
tagOf_PrimOp (IndexOffForeignObjOp CharRep) = ILIT(172)
tagOf_PrimOp (IndexOffForeignObjOp IntRep) = ILIT(173)
tagOf_PrimOp (IndexOffForeignObjOp WordRep) = ILIT(174)
tagOf_PrimOp (IndexOffForeignObjOp AddrRep) = ILIT(175)
tagOf_PrimOp (IndexOffForeignObjOp FloatRep) = ILIT(176)
tagOf_PrimOp (IndexOffForeignObjOp DoubleRep) = ILIT(177)
tagOf_PrimOp (IndexOffForeignObjOp StablePtrRep) = ILIT(178)
tagOf_PrimOp (IndexOffForeignObjOp Int64Rep) = ILIT(179)
tagOf_PrimOp (IndexOffForeignObjOp Word64Rep) = ILIT(180)
tagOf_PrimOp (WriteOffAddrOp CharRep) = ILIT(181)
tagOf_PrimOp (WriteOffAddrOp IntRep) = ILIT(182)
tagOf_PrimOp (WriteOffAddrOp WordRep) = ILIT(183)
tagOf_PrimOp (WriteOffAddrOp AddrRep) = ILIT(184)
tagOf_PrimOp (WriteOffAddrOp FloatRep) = ILIT(185)
tagOf_PrimOp (WriteOffAddrOp DoubleRep) = ILIT(186)
tagOf_PrimOp (WriteOffAddrOp StablePtrRep) = ILIT(187)
tagOf_PrimOp (WriteOffAddrOp ForeignObjRep) = ILIT(188)
tagOf_PrimOp (WriteOffAddrOp Int64Rep) = ILIT(189)
tagOf_PrimOp (WriteOffAddrOp Word64Rep) = ILIT(190)
tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(191)
tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(192)
tagOf_PrimOp SizeofByteArrayOp = ILIT(193)
tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(194)
tagOf_PrimOp NewSynchVarOp = ILIT(195)
tagOf_PrimOp TakeMVarOp = ILIT(196)
tagOf_PrimOp PutMVarOp = ILIT(197)
tagOf_PrimOp ReadIVarOp = ILIT(198)
tagOf_PrimOp WriteIVarOp = ILIT(199)
tagOf_PrimOp MakeForeignObjOp = ILIT(200)
tagOf_PrimOp WriteForeignObjOp = ILIT(201)
tagOf_PrimOp MakeStablePtrOp = ILIT(202)
tagOf_PrimOp DeRefStablePtrOp = ILIT(203)
tagOf_PrimOp (CCallOp _ _ _ _ _ _) = ILIT(204)
tagOf_PrimOp ErrorIOPrimOp = ILIT(205)
tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(206)
tagOf_PrimOp SeqOp = ILIT(207)
tagOf_PrimOp ParOp = ILIT(208)
tagOf_PrimOp ForkOp = ILIT(209)
tagOf_PrimOp DelayOp = ILIT(210)
tagOf_PrimOp WaitReadOp = ILIT(211)
tagOf_PrimOp WaitWriteOp = ILIT(212)
tagOf_PrimOp ParGlobalOp = ILIT(213)
tagOf_PrimOp ParLocalOp = ILIT(214)
tagOf_PrimOp ParAtOp = ILIT(215)
tagOf_PrimOp ParAtAbsOp = ILIT(216)
tagOf_PrimOp ParAtRelOp = ILIT(217)
tagOf_PrimOp ParAtForNowOp = ILIT(218)
tagOf_PrimOp CopyableOp = ILIT(219)
tagOf_PrimOp NoFollowOp = ILIT(220)
tagOf_PrimOp SameMVarOp = ILIT(221)
tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
......@@ -625,6 +636,7 @@ allThePrimOps
NewByteArrayOp AddrRep,
NewByteArrayOp FloatRep,
NewByteArrayOp DoubleRep,
NewByteArrayOp StablePtrRep,
SameMutableArrayOp,
SameMutableByteArrayOp,
ReadArrayOp,
......@@ -636,6 +648,7 @@ allThePrimOps
ReadByteArrayOp AddrRep,
ReadByteArrayOp FloatRep,
ReadByteArrayOp DoubleRep,
ReadByteArrayOp StablePtrRep,
ReadByteArrayOp Int64Rep,
ReadByteArrayOp Word64Rep,
WriteByteArrayOp CharRep,
......@@ -644,6 +657,7 @@ allThePrimOps
WriteByteArrayOp AddrRep,
WriteByteArrayOp FloatRep,
WriteByteArrayOp DoubleRep,
WriteByteArrayOp StablePtrRep,
WriteByteArrayOp Int64Rep,
WriteByteArrayOp Word64Rep,
IndexByteArrayOp CharRep,
......@@ -652,6 +666,7 @@ allThePrimOps
IndexByteArrayOp AddrRep,
IndexByteArrayOp FloatRep,
IndexByteArrayOp DoubleRep,
IndexByteArrayOp StablePtrRep,
IndexByteArrayOp Int64Rep,
IndexByteArrayOp Word64Rep,
IndexOffAddrOp CharRep,
......@@ -660,6 +675,7 @@ allThePrimOps
IndexOffAddrOp AddrRep,
IndexOffAddrOp FloatRep,
IndexOffAddrOp DoubleRep,
IndexOffAddrOp StablePtrRep,
IndexOffAddrOp Int64Rep,
IndexOffAddrOp Word64Rep,
IndexOffForeignObjOp CharRep,
......@@ -668,6 +684,7 @@ allThePrimOps
IndexOffForeignObjOp WordRep,
IndexOffForeignObjOp FloatRep,
IndexOffForeignObjOp DoubleRep,
IndexOffForeignObjOp StablePtrRep,
IndexOffForeignObjOp Int64Rep,
IndexOffForeignObjOp Word64Rep,
WriteOffAddrOp CharRep,
......@@ -676,6 +693,8 @@ allThePrimOps
WriteOffAddrOp AddrRep,
WriteOffAddrOp FloatRep,
WriteOffAddrOp DoubleRep,
WriteOffAddrOp StablePtrRep,
WriteOffAddrOp ForeignObjRep,
WriteOffAddrOp Int64Rep,
WriteOffAddrOp Word64Rep,
UnsafeFreezeArrayOp,
......@@ -1121,18 +1140,23 @@ primOpInfo (ReadByteArrayOp kind)
(str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("read" ++ str ++ "Array#")
relevant_tycon = assoc "primOpInfo" tbl kind
relevant_tycon = (assoc "primOpInfo{ReadByteArrayOp}" tbl kind)
(tycon_args, tvs)
| kind == StablePtrRep = ([s, betaTy], [s_tv, betaTyVar])
| otherwise = ([s], [s_tv])
in
AlgResult op_str [s_tv]
AlgResult op_str tvs
[mkMutableByteArrayPrimTy s, intPrimTy, mkStatePrimTy s]
relevant_tycon [s]
relevant_tycon tycon_args
where
tbl = [ (CharRep, stateAndCharPrimTyCon),
(IntRep, stateAndIntPrimTyCon),
(WordRep, stateAndWordPrimTyCon),
(AddrRep, stateAndAddrPrimTyCon),
(FloatRep, stateAndFloatPrimTyCon),
(DoubleRep, stateAndDoublePrimTyCon) ]
tbl = [ (CharRep, stateAndCharPrimTyCon),
(IntRep, stateAndIntPrimTyCon),
(WordRep, stateAndWordPrimTyCon),
(AddrRep, stateAndAddrPrimTyCon),
(FloatRep, stateAndFloatPrimTyCon),
(StablePtrRep, stateAndStablePtrPrimTyCon),
(DoubleRep, stateAndDoublePrimTyCon) ]
-- How come there's no Word byte arrays? ADR
......@@ -1142,33 +1166,50 @@ primOpInfo (WriteByteArrayOp kind)
(str, prim_ty, _) = getPrimRepInfo kind
op_str = _PK_ ("write" ++ str ++ "Array#")
(the_prim_ty, tvs)
| kind == StablePtrRep = (mkStablePtrPrimTy betaTy, [s_tv, betaTyVar])
| otherwise = (prim_ty, [s_tv])
in
-- NB: *Prim*Result --
PrimResult op_str [s_tv]
[mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s]
PrimResult op_str tvs
[mkMutableByteArrayPrimTy s, intPrimTy, the_prim_ty, mkStatePrimTy s]
statePrimTyCon VoidRep [s]
primOpInfo (IndexByteArrayOp kind)
= let
(str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("index" ++ str ++ "Array#")
(prim_tycon_args, tvs)
| kind == StablePtrRep = ([alphaTy], [alphaTyVar])
| otherwise = ([],[])
in
-- NB: *Prim*Result --
PrimResult op_str [] [byteArrayPrimTy, intPrimTy] prim_tycon kind []
PrimResult op_str tvs [byteArrayPrimTy, intPrimTy] prim_tycon kind prim_tycon_args
primOpInfo (IndexOffAddrOp kind)
= let
(str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("index" ++ str ++ "OffAddr#")
(prim_tycon_args, tvs)
| kind == StablePtrRep = ([alphaTy], [alphaTyVar])
| otherwise = ([], [])
in
PrimResult op_str [] [addrPrimTy, intPrimTy] prim_tycon kind []
PrimResult op_str tvs [addrPrimTy, intPrimTy] prim_tycon kind prim_tycon_args
primOpInfo (IndexOffForeignObjOp kind)
= let
(str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("index" ++ str ++ "OffForeignObj#")
(prim_tycon_args, tvs)
| kind == StablePtrRep = ([alphaTy], [alphaTyVar])
| otherwise = ([], [])
in
PrimResult op_str [] [foreignObjPrimTy, intPrimTy] prim_tycon kind []
PrimResult op_str tvs [foreignObjPrimTy, intPrimTy] prim_tycon kind prim_tycon_args
primOpInfo (WriteOffAddrOp kind)
= let
......@@ -1964,8 +2005,8 @@ pprPrimOp (CCallOp fun is_casm may_gc cconv arg_tys res_ty)
ppr_fun =
case fun of
Nothing -> ptext SLIT("<dynamic>")
Just fn -> ptext fn
Right _ -> ptext SLIT("<dynamic>")
Left fn -> ptext fn
in
hcat [ ifPprDebug callconv
......
......@@ -87,6 +87,9 @@ getPrimRepInfo FloatRep = ("Float", floatPrimTy, floatPrimTyCon)
getPrimRepInfo DoubleRep = ("Double", doublePrimTy, doublePrimTyCon)
getPrimRepInfo Int64Rep = ("Int64", int64PrimTy, int64PrimTyCon)
getPrimRepInfo Word64Rep = ("Word64", word64PrimTy, word64PrimTyCon)
getPrimRepInfo StablePtrRep = ("StablePtr", mkStablePtrPrimTy alphaTy, stablePtrPrimTyCon)
getPrimRepInfo ForeignObjRep = ("ForeignObj", foreignObjPrimTy, foreignObjPrimTyCon)
\end{code}
%************************************************************************
......
......@@ -30,6 +30,8 @@ import UniqSupply ( UniqSupply, UniqSM,
returnUs, thenUs, initUs,
mapUs, getUnique
)
import PrimOp ( PrimOp(..) )
import Outputable ( panic )
isLeakFreeType x y = False -- safe option; ToDo
......@@ -241,10 +243,17 @@ coreExprToStg env (Con con args)
returnUs (StgCon con stg_atoms bOGUS_LVs)
coreExprToStg env (Prim op args)
= let
= mkPrimOpUnique op `thenUs` \ op' ->
let
(types, stg_atoms) = coreArgsToStg env args
in
returnUs (StgPrim op stg_atoms bOGUS_LVs)
returnUs (StgPrim op' stg_atoms bOGUS_LVs)
where
mkPrimOpUnique (CCallOp (Right _) a b c d e) =
getUnique `thenUs` \ u ->
returnUs (CCallOp (Right u) a b c d e)
mkPrimOpUnique op = returnUs op
\end{code}
%************************************************************************
......
......@@ -356,7 +356,7 @@ tcCorePrim (UfOtherOp op)
tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
= mapTc tcHsType arg_tys `thenTc` \ arg_tys' ->
tcHsType res_ty `thenTc` \ res_ty' ->
returnTc (CCallOp (Just str) casm gc cCallConv arg_tys' res_ty')
returnTc (CCallOp (Left str) casm gc cCallConv arg_tys' res_ty')
\end{code}
\begin{code}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment