import TysWiredIn
import CStrings ( identToC )
-import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
+import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
-import PprStyle ( codeStyle, PprStyle(..){-ToDo:rm-} )
+import PprStyle ( codeStyle, ifaceStyle )
import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
| TakeMVarOp | PutMVarOp
| ReadIVarOp | WriteIVarOp
- | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL)
+ | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL)
+ | WriteForeignObjOp -- modifying foreign objects [obscuro factor: 200]
| MakeStablePtrOp | DeRefStablePtrOp
\end{code}
tagOf_PrimOp ReadIVarOp = ILIT(153)
tagOf_PrimOp WriteIVarOp = ILIT(154)
tagOf_PrimOp MakeForeignObjOp = ILIT(155)
-tagOf_PrimOp MakeStablePtrOp = ILIT(156)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(157)
-tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(158)
-tagOf_PrimOp ErrorIOPrimOp = ILIT(159)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(160)
-tagOf_PrimOp SeqOp = ILIT(161)
-tagOf_PrimOp ParOp = ILIT(162)
-tagOf_PrimOp ForkOp = ILIT(163)
-tagOf_PrimOp DelayOp = ILIT(164)
-tagOf_PrimOp WaitReadOp = ILIT(165)
-tagOf_PrimOp WaitWriteOp = ILIT(166)
-
-tagOf_PrimOp ParGlobalOp = ILIT(167)
-tagOf_PrimOp ParLocalOp = ILIT(168)
-tagOf_PrimOp ParAtOp = ILIT(169)
-tagOf_PrimOp ParAtAbsOp = ILIT(170)
-tagOf_PrimOp ParAtRelOp = ILIT(171)
-tagOf_PrimOp ParAtForNowOp = ILIT(172)
-tagOf_PrimOp CopyableOp = ILIT(173)
-tagOf_PrimOp NoFollowOp = ILIT(174)
+tagOf_PrimOp WriteForeignObjOp = ILIT(156)
+tagOf_PrimOp MakeStablePtrOp = ILIT(157)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(158)
+tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(159)
+tagOf_PrimOp ErrorIOPrimOp = ILIT(160)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(161)
+tagOf_PrimOp SeqOp = ILIT(162)
+tagOf_PrimOp ParOp = ILIT(163)
+tagOf_PrimOp ForkOp = ILIT(164)
+tagOf_PrimOp DelayOp = ILIT(165)
+tagOf_PrimOp WaitReadOp = ILIT(166)
+tagOf_PrimOp WaitWriteOp = ILIT(167)
+
+tagOf_PrimOp ParGlobalOp = ILIT(168)
+tagOf_PrimOp ParLocalOp = ILIT(169)
+tagOf_PrimOp ParAtOp = ILIT(170)
+tagOf_PrimOp ParAtAbsOp = ILIT(171)
+tagOf_PrimOp ParAtRelOp = ILIT(172)
+tagOf_PrimOp ParAtForNowOp = ILIT(173)
+tagOf_PrimOp CopyableOp = ILIT(174)
+tagOf_PrimOp NoFollowOp = ILIT(175)
tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
ReadIVarOp,
WriteIVarOp,
MakeForeignObjOp,
+ WriteForeignObjOp,
MakeStablePtrOp,
DeRefStablePtrOp,
ReallyUnsafePtrEqualityOp,
primOpInfo CharLtOp = Compare SLIT("ltChar#") charPrimTy
primOpInfo CharLeOp = Compare SLIT("leChar#") charPrimTy
-primOpInfo IntGtOp = Compare SLIT("gtInt#") intPrimTy
-primOpInfo IntGeOp = Compare SLIT("geInt#") intPrimTy
-primOpInfo IntEqOp = Compare SLIT("eqInt#") intPrimTy
-primOpInfo IntNeOp = Compare SLIT("neInt#") intPrimTy
-primOpInfo IntLtOp = Compare SLIT("ltInt#") intPrimTy
-primOpInfo IntLeOp = Compare SLIT("leInt#") intPrimTy
+primOpInfo IntGtOp = Compare SLIT(">#") intPrimTy
+primOpInfo IntGeOp = Compare SLIT(">=#") intPrimTy
+primOpInfo IntEqOp = Compare SLIT("==#") intPrimTy
+primOpInfo IntNeOp = Compare SLIT("/=#") intPrimTy
+primOpInfo IntLtOp = Compare SLIT("<#") intPrimTy
+primOpInfo IntLeOp = Compare SLIT("<=#") intPrimTy
primOpInfo WordGtOp = Compare SLIT("gtWord#") wordPrimTy
primOpInfo WordGeOp = Compare SLIT("geWord#") wordPrimTy
primOpInfo FloatLtOp = Compare SLIT("ltFloat#") floatPrimTy
primOpInfo FloatLeOp = Compare SLIT("leFloat#") floatPrimTy
-primOpInfo DoubleGtOp = Compare SLIT("gtDouble#") doublePrimTy
-primOpInfo DoubleGeOp = Compare SLIT("geDouble#") doublePrimTy
-primOpInfo DoubleEqOp = Compare SLIT("eqDouble#") doublePrimTy
-primOpInfo DoubleNeOp = Compare SLIT("neDouble#") doublePrimTy
-primOpInfo DoubleLtOp = Compare SLIT("ltDouble#") doublePrimTy
-primOpInfo DoubleLeOp = Compare SLIT("leDouble#") doublePrimTy
+primOpInfo DoubleGtOp = Compare SLIT(">##") doublePrimTy
+primOpInfo DoubleGeOp = Compare SLIT(">=##") doublePrimTy
+primOpInfo DoubleEqOp = Compare SLIT("==##") doublePrimTy
+primOpInfo DoubleNeOp = Compare SLIT("/=##") doublePrimTy
+primOpInfo DoubleLtOp = Compare SLIT("<##") doublePrimTy
+primOpInfo DoubleLeOp = Compare SLIT("<=##") doublePrimTy
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-primOpInfo IntAddOp = Dyadic SLIT("plusInt#") intPrimTy
-primOpInfo IntSubOp = Dyadic SLIT("minusInt#") intPrimTy
-primOpInfo IntMulOp = Dyadic SLIT("timesInt#") intPrimTy
+primOpInfo IntAddOp = Dyadic SLIT("+#") intPrimTy
+primOpInfo IntSubOp = Dyadic SLIT("-#") intPrimTy
+primOpInfo IntMulOp = Dyadic SLIT("*#") intPrimTy
primOpInfo IntQuotOp = Dyadic SLIT("quotInt#") intPrimTy
primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy
similar).
\begin{code}
-primOpInfo DoubleAddOp = Dyadic SLIT("plusDouble#") doublePrimTy
-primOpInfo DoubleSubOp = Dyadic SLIT("minusDouble#") doublePrimTy
-primOpInfo DoubleMulOp = Dyadic SLIT("timesDouble#") doublePrimTy
-primOpInfo DoubleDivOp = Dyadic SLIT("divideDouble#") doublePrimTy
+primOpInfo DoubleAddOp = Dyadic SLIT("+##") doublePrimTy
+primOpInfo DoubleSubOp = Dyadic SLIT("-##") doublePrimTy
+primOpInfo DoubleMulOp = Dyadic SLIT("*##") doublePrimTy
+primOpInfo DoubleDivOp = Dyadic SLIT("/##") doublePrimTy
primOpInfo DoubleNegOp = Monadic SLIT("negateDouble#") doublePrimTy
primOpInfo Double2IntOp = Coercing SLIT("double2Int#") doublePrimTy intPrimTy
primOpInfo DoubleSinhOp = Monadic SLIT("sinhDouble#") doublePrimTy
primOpInfo DoubleCoshOp = Monadic SLIT("coshDouble#") doublePrimTy
primOpInfo DoubleTanhOp = Monadic SLIT("tanhDouble#") doublePrimTy
-primOpInfo DoublePowerOp= Dyadic SLIT("powerDouble#") doublePrimTy
+primOpInfo DoublePowerOp= Dyadic SLIT("**##") doublePrimTy
\end{code}
%************************************************************************
%************************************************************************
%* *
-\subsubsection[PrimOps-makeForeignObj]{PrimOpInfo for Foreign Objects}
+\subsubsection[PrimOps-ForeignObj]{PrimOpInfo for Foreign Objects}
%* *
%************************************************************************
associated with the object is invoked (currently, each ForeignObj has a
direct reference to its finaliser). -- SOF
-The only function defined over @ForeignObj@s is:
+A @ForeignObj@ is created by the @makeForeignObj#@ primitive:
\begin{pseudocode}
makeForeignObj# :: Addr# -- foreign object
-> StateAndForeignObj# _RealWorld# ForeignObj#
\end{pseudocode}
+
\begin{code}
primOpInfo MakeForeignObjOp
= AlgResult SLIT("makeForeignObj#") []
stateAndForeignObjPrimTyCon [realWorldTy]
\end{code}
+[Experimental--SOF]
+In addition, another @ForeignObj@ primitive is provided for destructively modifying
+the external object wrapped up inside a @ForeignObj@. This primitive is used
+when a mixed programming interface of implicit and explicit de-allocation is used,
+e.g., if @ForeignObj@s are used to implement @Handle@s, then @Handle@s can be
+released either explicitly (through @hClose@) or implicitly (via a finaliser).
+When releasing/closing the @Handle@ explicitly, care must be taken to avoid having
+the finaliser for the embedded @ForeignObj@ attempt the same thing later.
+We deal with this situation, by allowing the programmer to destructively modify
+the data field of the @ForeignObj@ to hold a special value the finaliser recognises,
+and does not attempt to free (e.g., filling the data slot with \tr{NULL}).
+
+\begin{pseudocode}
+writeForeignObj# :: ForeignObj# -- foreign object
+ -> Addr# -- new data value
+ -> StateAndForeignObj# _RealWorld# ForeignObj#
+\end{pseudocode}
+
+\begin{code}
+primOpInfo WriteForeignObjOp
+ = let {
+ s = alphaTy; s_tv = alphaTyVar
+ } in
+ PrimResult SLIT("writeForeignObj#") [s_tv]
+ [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s]
+ statePrimTyCon VoidRep [s]
+\end{code}
+
%************************************************************************
%* *
\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for ``stable pointers''}
primOpInfo (CCallOp _ _ _ arg_tys result_ty)
= AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
where
- (result_tycon, tys_applied, _) = -- trace "PrimOp.getAppDataTyConExpandingDicts" $
+ (result_tycon, tys_applied, _) = --trace "PrimOp.getAppDataTyConExpandingDicts" $
getAppDataTyConExpandingDicts result_ty
#ifdef DEBUG
(addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
(intOff mIN_MP_INT_SIZE)))
--- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_)
--- or if it returns a ForeignObj.
+{-
+ ccall may allocate heap if it is explicitly allowed to (_ccall_gc_)
+ or if it returns a ForeignObj.
+ Hmm..the allocation for makeForeignObj# is known (and fixed), so
+ why dod we need to be so indeterminate about it? --SOF
+-}
primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired
primOpHeapReq (CCallOp _ _ mayGC@False _ _) = NoHeapRequired
primOpHeapReq MakeForeignObjOp = VariableHeapRequired
+primOpHeapReq WriteForeignObjOp = NoHeapRequired
-- this occasionally has to expand the Stable Pointer table
primOpHeapReq MakeStablePtrOp = VariableHeapRequired
fragilePrimOp ParOp = True
fragilePrimOp ForkOp = True
fragilePrimOp SeqOp = True
-fragilePrimOp MakeForeignObjOp = True -- SOF
+fragilePrimOp MakeForeignObjOp = True -- SOF
+fragilePrimOp WriteForeignObjOp = True -- SOF
fragilePrimOp MakeStablePtrOp = True
fragilePrimOp DeRefStablePtrOp = True -- ??? JSM & ADR
primOpNeedsWrapper DoubleDecodeOp = True
primOpNeedsWrapper MakeForeignObjOp = True
+primOpNeedsWrapper WriteForeignObjOp = True
primOpNeedsWrapper MakeStablePtrOp = True
primOpNeedsWrapper DeRefStablePtrOp = True
= let
before
= if is_casm then
- if may_gc then "(_casm_GC_ ``" else "(_casm_ ``"
+ if may_gc then "_casm_GC_ ``" else "_casm_ ``"
else
- if may_gc then "(_ccall_GC_ " else "(_ccall_ "
+ if may_gc then "_ccall_GC_ " else "_ccall_ "
after
= if is_casm then ppStr "''" else ppNil
pp_tys
- = ppBesides [ppStr " { [",
- ppIntersperse pp'SP{-'-} (map (pprParendGenType sty) arg_tys),
- ppRbrack, ppSP, pprParendGenType sty res_ty, ppStr " })"]
-
+ = ppCat (map (pprParendGenType sty) (res_ty:arg_tys))
in
- ppBesides [ppStr before, ppPStr fun, after, pp_tys]
+ ppBesides [ppStr before, ppPStr fun, after, ppSP, ppLbrack, pp_tys, ppRbrack]
pprPrimOp sty other_op
- = let
- str = primOp_str other_op
- in
- (if codeStyle sty then identToC else ppPStr) str
+ | codeStyle sty -- For C just print the primop itself
+ = identToC str
+
+ | ifaceStyle sty -- For interfaces Print it qualified with GHC.
+ = ppPStr SLIT("GHC.") `ppBeside` ppPStr str
+
+ | otherwise -- Unqualified is good enough
+ = ppPStr str
+ where
+ str = primOp_str other_op
+
+
instance Outputable PrimOp where
ppr sty op = pprPrimOp sty op
projects / ghc-hetmet.git / blobdiff