X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=7ba7dd392b453cc9064c4a5b7477f3b5b536910b;hb=2494407a750053daa61718fac371487d04818e57;hp=8ab3a4bf5a3662ebb55457b4aceae36ce416fb21;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 8ab3a4b..7ba7dd3 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -36,15 +36,15 @@ import TysPrim 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(..) ) import TyCon ( TyCon{-instances-} ) import Type ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts, - mkForAllTys, mkFunTys, applyTyCon, typePrimRep + mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep ) import TyVar ( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Eq-} ) @@ -154,7 +154,8 @@ data PrimOp | 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} @@ -413,26 +414,27 @@ tagOf_PrimOp PutMVarOp = ILIT(152) 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" @@ -597,6 +599,7 @@ allThePrimOps ReadIVarOp, WriteIVarOp, MakeForeignObjOp, + WriteForeignObjOp, MakeStablePtrOp, DeRefStablePtrOp, ReallyUnsafePtrEqualityOp, @@ -702,12 +705,12 @@ primOpInfo CharNeOp = Compare SLIT("neChar#") charPrimTy 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 @@ -730,12 +733,12 @@ primOpInfo FloatNeOp = Compare SLIT("neFloat#") floatPrimTy 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} %************************************************************************ @@ -756,9 +759,9 @@ primOpInfo ChrOp = Coercing SLIT("chr#") intPrimTy charPrimTy %************************************************************************ \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 @@ -851,10 +854,10 @@ primOpInfo FloatPowerOp = Dyadic SLIT("powerFloat#") floatPrimTy 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 @@ -875,7 +878,7 @@ primOpInfo DoubleAtanOp = Monadic SLIT("atanDouble#") doublePrimTy 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} %************************************************************************ @@ -1147,7 +1150,7 @@ primOpInfo WaitWriteOp %************************************************************************ %* * -\subsubsection[PrimOps-makeForeignObj]{PrimOpInfo for Foreign Objects} +\subsubsection[PrimOps-ForeignObj]{PrimOpInfo for Foreign Objects} %* * %************************************************************************ @@ -1164,7 +1167,7 @@ When a @ForeignObj@ becomes garbage, a user-defined finalisation routine 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 @@ -1172,6 +1175,7 @@ makeForeignObj# :: Addr# -- foreign object -> StateAndForeignObj# _RealWorld# ForeignObj# \end{pseudocode} + \begin{code} primOpInfo MakeForeignObjOp = AlgResult SLIT("makeForeignObj#") [] @@ -1179,6 +1183,34 @@ primOpInfo MakeForeignObjOp 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''} @@ -1332,7 +1364,7 @@ primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld# statePrimTyCon VoidRep [realWorldTy] where primio_ish_ty result - = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [result, mkStateTy realWorldTy]) + = mkFunTy (mkStateTy realWorldTy) (mkTupleTy 2 [result, mkStateTy realWorldTy]) \end{code} %************************************************************************ @@ -1345,7 +1377,7 @@ primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld# 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 @@ -1400,13 +1432,18 @@ primOpHeapReq DoubleDecodeOp = FixedHeapRequired (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 @@ -1553,7 +1590,8 @@ fragilePrimOp :: PrimOp -> Bool 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 @@ -1625,6 +1663,7 @@ primOpNeedsWrapper DoubleEncodeOp = True primOpNeedsWrapper DoubleDecodeOp = True primOpNeedsWrapper MakeForeignObjOp = True +primOpNeedsWrapper WriteForeignObjOp = True primOpNeedsWrapper MakeStablePtrOp = True primOpNeedsWrapper DeRefStablePtrOp = True @@ -1660,7 +1699,7 @@ primOpType op Dyadic str ty -> dyadic_fun_ty ty Monadic str ty -> monadic_fun_ty ty Compare str ty -> compare_fun_ty ty - Coercing str ty1 ty2 -> mkFunTys [ty1] ty2 + Coercing str ty1 ty2 -> mkFunTy ty1 ty2 PrimResult str tyvars arg_tys prim_tycon kind res_tys -> mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)) @@ -1726,7 +1765,7 @@ commutableOp _ = False Utils: \begin{code} dyadic_fun_ty ty = mkFunTys [ty, ty] ty -monadic_fun_ty ty = mkFunTys [ty] ty +monadic_fun_ty ty = mkFunTy ty ty compare_fun_ty ty = mkFunTys [ty, ty] boolTy \end{code} @@ -1742,26 +1781,31 @@ pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty) = 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