primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
primOpHasSideEffects,
- getPrimOpResultInfo, PrimOpResultInfo(..),
-
- pprPrimOp,
-
- CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp,
- isDynamicTarget, dynamicTarget, setCCallUnique
+ getPrimOpResultInfo, PrimOpResultInfo(..)
) where
#include "HsVersions.h"
import TysWiredIn
import Demand ( wwLazy, wwPrim, wwStrict, StrictnessInfo(..) )
-import Var ( TyVar, Id )
-import CallConv ( CallConv, pprCallConv )
-import Name ( Name, mkWiredInIdName )
-import RdrName ( RdrName, mkRdrQual )
-import OccName ( OccName, pprOccName, mkSrcVarOcc )
-import TyCon ( TyCon, tyConArity )
-import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, mkTyVarTys,
- mkTyConApp, typePrimRep,
- splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe,
- UsageAnn(..), mkUsgTy
+import Var ( TyVar )
+import Name ( Name, mkWiredInName )
+import RdrName ( RdrName, mkRdrOrig )
+import OccName ( OccName, pprOccName, mkVarOcc )
+import TyCon ( TyCon )
+import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep,
+ splitFunTy_maybe, tyConAppTyCon, splitTyConApp,
+ mkUTy, usOnce, usMany
)
-import Unique ( Unique, mkPrimOpIdUnique )
+import Unique ( mkPrimOpIdUnique )
import BasicTypes ( Arity, Boxity(..) )
-import CStrings ( CLabelString, pprCLabelString )
import PrelNames ( pREL_GHC, pREL_GHC_Name )
import Outputable
import Util ( zipWithEqual )
-import GlaExts ( Int(..), Int#, (==#) )
+import FastTypes
\end{code}
%************************************************************************
-- supplies:
-- data PrimOp = ...
#include "primop-data-decl.hs-incl"
- | CCallOp CCall -- and don't forget to add CCall
\end{code}
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
allThePrimOps :: [PrimOp]
allThePrimOps =
#include "primop-list.hs-incl"
--- Doesn't include CCall, which is really a family of primops
\end{code}
%************************************************************************
[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}
%************************************************************************
perform a heap check or they block.
\begin{code}
-primOpOutOfLine (CCallOp c_call) = ccallMayGC c_call
#include "primop-out-of-line.hs-incl"
\end{code}
primOpOkForSpeculation :: PrimOp -> Bool
-- See comments with CoreUtils.exprOkForSpeculation
primOpOkForSpeculation op
- = not (primOpCanFail op || primOpHasSideEffects op || primOpOutOfLine op)
+ = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op)
\end{code}
\begin{code}
primOpIsCheap :: PrimOp -> Bool
- -- See comments with CoreUtils.exprOkForSpeculation
-primOpIsCheap op = not (primOpHasSideEffects op || primOpOutOfLine op)
+primOpIsCheap op = False
+ -- March 2001: be less eager to inline PrimOps
+ -- Was: not (primOpHasSideEffects op || primOpOutOfLine op)
\end{code}
primOpIsDupable
\begin{code}
primOpHasSideEffects :: PrimOp -> Bool
-primOpHasSideEffects (CCallOp _) = True
#include "primop-has-side-effects.hs-incl"
\end{code}
\begin{code}
primOpNeedsWrapper :: PrimOp -> Bool
-primOpNeedsWrapper (CCallOp _) = True
#include "primop-needs-wrapper.hs-incl"
\end{code}
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
-- as required by the UsageSP inference.
primOpUsg :: PrimOp -> ([TyVar],[Type],Type)
-primOpUsg p@(CCallOp _) = mangle p [] mkM
#include "primop-usage.hs-incl"
-- Things with no Haskell pointers inside: in actuality, usages are
-- 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
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}
-- be out of line, or the code generator won't work.
getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
-getPrimOpResultInfo (CCallOp _)
- = ReturnsAlg unboxedPairTyCon
getPrimOpResultInfo op
= case (primOpInfo op) of
Dyadic _ ty -> ReturnsPrim (typePrimRep ty)
Monadic _ ty -> ReturnsPrim (typePrimRep ty)
Compare _ ty -> ReturnsAlg boolTyCon
- GenPrimOp _ _ _ ty ->
- let rep = typePrimRep ty in
- case rep of
- PtrRep -> case splitAlgTyConApp_maybe ty of
- Nothing -> panic "getPrimOpResultInfo"
- Just (tc,_,_) -> ReturnsAlg tc
- other -> ReturnsPrim other
+ GenPrimOp _ _ _ ty -> case typePrimRep ty of
+ PtrRep -> ReturnsAlg (tyConAppTyCon ty)
+ rep -> ReturnsPrim rep
\end{code}
The commutable ops are those for which we will try to move constants
Utils:
\begin{code}
-mkPrimTyApp :: [TyVar] -> PrimRep -> ([TyVar], Type)
- -- CharRep --> ([], Char#)
- -- StablePtrRep --> ([a], StablePtr# a)
-mkPrimTyApp tvs kind
- = (forall_tvs, mkTyConApp tycon (mkTyVarTys forall_tvs))
- where
- tycon = primRepTyCon kind
- forall_tvs = take (tyConArity tycon) tvs
-
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
monadic_fun_ty ty = mkFunTy ty ty
compare_fun_ty ty = mkFunTys [ty, ty] boolTy
Output stuff:
\begin{code}
pprPrimOp :: PrimOp -> SDoc
-
-pprPrimOp (CCallOp c_call) = pprCCallOp c_call
pprPrimOp other_op
= getPprStyle $ \ sty ->
if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC.
\end{code}
-%************************************************************************
-%* *
-\subsubsection{CCalls}
-%* *
-%************************************************************************
-
-A special ``trap-door'' to use in making calls direct to C functions:
-\begin{code}
-data CCall
- = CCall CCallTarget
- Bool -- True <=> really a "casm"
- Bool -- True <=> might invoke Haskell GC
- CallConv -- calling convention to use.
- deriving( Eq )
-
-data CCallTarget
- = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
- | DynamicTarget Unique -- First argument (an Addr#) is the function pointer
- -- (unique is used to generate a 'typedef' to cast
- -- the function pointer if compiling the ccall# down to
- -- .hc code - can't do this inline for tedious reasons.)
-
-instance Eq CCallTarget where
- (StaticTarget l1) == (StaticTarget l2) = l1 == l2
- (DynamicTarget _) == (DynamicTarget _) = True
- -- Ignore the arbitrary unique; this is important when comparing
- -- a dynamic ccall read from an interface file A.hi with the
- -- one constructed from A.hs, when deciding whether the interface
- -- has changed
- t1 == t2 = False
-
-ccallMayGC :: CCall -> Bool
-ccallMayGC (CCall _ _ may_gc _) = may_gc
-
-ccallIsCasm :: CCall -> Bool
-ccallIsCasm (CCall _ c_asm _ _) = c_asm
-
-isDynamicTarget (DynamicTarget _) = True
-isDynamicTarget (StaticTarget _) = False
-
-dynamicTarget :: CCallTarget
-dynamicTarget = DynamicTarget (panic "Unique in DynamicTarget not yet set")
- -- The unique is really only to do with code generation, so it
- -- is only set in CoreToStg; before then it's just an error message
-
-setCCallUnique :: CCall -> Unique -> CCall
-setCCallUnique (CCall (DynamicTarget _) is_asm may_gc cconv) uniq
- = CCall (DynamicTarget uniq) is_asm may_gc cconv
-setCCallUnique ccall uniq = ccall
-\end{code}
-
-\begin{code}
-pprCCallOp (CCall fun is_casm may_gc cconv)
- = hcat [ ifPprDebug callconv
- , text "__", ppr_dyn
- , text before , ppr_fun , after]
- where
- callconv = text "{-" <> pprCallConv cconv <> text "-}"
-
- before
- | is_casm && may_gc = "casm_GC ``"
- | is_casm = "casm ``"
- | may_gc = "ccall_GC "
- | otherwise = "ccall "
-
- after
- | is_casm = text "''"
- | otherwise = empty
-
- ppr_dyn = case fun of
- DynamicTarget _ -> text "dyn_"
- _ -> empty
-
- ppr_fun = case fun of
- DynamicTarget _ -> text "\"\""
- StaticTarget fn -> pprCLabelString fn
-\end{code}
projects / ghc-hetmet.git / blobdiff