X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=e5c172728ba86cb203413ffd3d92e4a3684da89e;hb=871db587eda4fcba3fdc049b225a1d63a4ebe641;hp=9e946d8445f54f9bece409e7638a7e14dd6d1037;hpb=3cc69ccd1a3eaaf59f0031673573baf93332c514;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 9e946d8..e5c1727 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -17,8 +17,6 @@ module PrimOp ( getPrimOpResultInfo, PrimOpResultInfo(..), - pprPrimOp, - CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp, isDynamicTarget, dynamicTarget, setCCallUnique ) where @@ -30,16 +28,16 @@ import TysPrim import TysWiredIn import Demand ( wwLazy, wwPrim, wwStrict, StrictnessInfo(..) ) -import Var ( TyVar, Id ) +import Var ( TyVar ) import CallConv ( CallConv, pprCallConv ) -import Name ( Name, mkWiredInIdName ) -import RdrName ( RdrName, mkRdrQual ) -import OccName ( OccName, pprOccName, mkSrcVarOcc ) +import Name ( Name, mkWiredInName ) +import RdrName ( RdrName, mkRdrOrig ) +import OccName ( OccName, pprOccName, mkVarOcc ) import TyCon ( TyCon, tyConArity ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, mkTyVarTys, mkTyConApp, typePrimRep, - splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe, - UsageAnn(..), mkUsgTy + splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp, + mkUTy, usOnce, usMany ) import Unique ( Unique, mkPrimOpIdUnique ) import BasicTypes ( Arity, Boxity(..) ) @@ -47,7 +45,7 @@ import CStrings ( CLabelString, pprCLabelString ) import PrelNames ( pREL_GHC, pREL_GHC_Name ) import Outputable import Util ( zipWithEqual ) -import GlaExts ( Int(..), Int#, (==#) ) +import FastTypes \end{code} %************************************************************************ @@ -70,22 +68,22 @@ Used for the Ord instance \begin{code} primOpTag :: PrimOp -> Int -primOpTag op = IBOX( tagOf_PrimOp op ) +primOpTag op = iBox (tagOf_PrimOp op) -- supplies --- tagOf_PrimOp :: PrimOp -> FAST_INT +-- tagOf_PrimOp :: PrimOp -> FastInt #include "primop-tag.hs-incl" tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op) instance Eq PrimOp where - op1 == op2 = tagOf_PrimOp op1 _EQ_ tagOf_PrimOp op2 + op1 == op2 = tagOf_PrimOp op1 ==# tagOf_PrimOp op2 instance Ord PrimOp where - op1 < op2 = tagOf_PrimOp op1 _LT_ tagOf_PrimOp op2 - op1 <= op2 = tagOf_PrimOp op1 _LE_ tagOf_PrimOp op2 - op1 >= op2 = tagOf_PrimOp op1 _GE_ tagOf_PrimOp op2 - op1 > op2 = tagOf_PrimOp op1 _GT_ tagOf_PrimOp op2 + op1 < op2 = tagOf_PrimOp op1 <# tagOf_PrimOp op2 + op1 <= op2 = tagOf_PrimOp op1 <=# tagOf_PrimOp op2 + op1 >= op2 = tagOf_PrimOp op1 >=# tagOf_PrimOp op2 + op1 > op2 = tagOf_PrimOp op1 ># tagOf_PrimOp op2 op1 `compare` op2 | op1 < op2 = LT | op1 == op2 = EQ | otherwise = GT @@ -134,10 +132,10 @@ data PrimOpInfo [Type] Type -mkDyadic str ty = Dyadic (mkSrcVarOcc str) ty -mkMonadic str ty = Monadic (mkSrcVarOcc str) ty -mkCompare str ty = Compare (mkSrcVarOcc str) ty -mkGenPrimOp str tvs tys ty = GenPrimOp (mkSrcVarOcc str) tvs tys ty +mkDyadic str ty = Dyadic (mkVarOcc str) ty +mkMonadic str ty = Monadic (mkVarOcc str) ty +mkCompare str ty = Compare (mkVarOcc str) ty +mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOcc str) tvs tys ty \end{code} %************************************************************************ @@ -437,19 +435,15 @@ primOpType op GenPrimOp occ tyvars arg_tys res_ty -> mkForAllTys tyvars (mkFunTys arg_tys res_ty) -mkPrimOpIdName :: PrimOp -> Id -> Name +mkPrimOpIdName :: PrimOp -> Name -- Make the name for the PrimOp's Id -- We have to pass in the Id itself because it's a WiredInId -- and hence recursive -mkPrimOpIdName op id - = mkWiredInIdName key pREL_GHC occ_name id - where - occ_name = primOpOcc op - key = mkPrimOpIdUnique (primOpTag op) - +mkPrimOpIdName op + = mkWiredInName pREL_GHC (primOpOcc op) (mkPrimOpIdUnique (primOpTag op)) primOpRdrName :: PrimOp -> RdrName -primOpRdrName op = mkRdrQual pREL_GHC_Name (primOpOcc op) +primOpRdrName op = mkRdrOrig pREL_GHC_Name (primOpOcc op) primOpOcc :: PrimOp -> OccName primOpOcc op = case (primOpInfo op) of @@ -493,11 +487,11 @@ primOpUsg p@(CCallOp _) = mangle p [] mkM -- Helper bits & pieces for usage info. -mkZ = mkUsgTy UsOnce -- pointed argument used zero -mkO = mkUsgTy UsOnce -- pointed argument used once -mkM = mkUsgTy UsMany -- pointed argument used multiply -mkP = mkUsgTy UsOnce -- unpointed argument -mkR = mkUsgTy UsMany -- unpointed result +mkZ = mkUTy usOnce -- pointed argument used zero +mkO = mkUTy usOnce -- pointed argument used once +mkM = mkUTy usMany -- pointed argument used multiply +mkP = mkUTy usOnce -- unpointed argument +mkR = mkUTy usMany -- unpointed result nomangle op = case primOpSig op of @@ -515,11 +509,9 @@ inFun op f g ty Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty) inUB op fs ty - = case splitTyConApp_maybe ty of - Just (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) ) - mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" - ($) fs tys) - Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty) + = case splitTyConApp ty of + (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) ) + mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" ($) fs tys) \end{code} \begin{code} @@ -543,7 +535,8 @@ getPrimOpResultInfo op let rep = typePrimRep ty in case rep of PtrRep -> case splitAlgTyConApp_maybe ty of - Nothing -> panic "getPrimOpResultInfo" + Nothing -> pprPanic "getPrimOpResultInfo" + (ppr ty <+> ppr op) Just (tc,_,_) -> ReturnsAlg tc other -> ReturnsPrim other \end{code}