import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised )
-import ForeignCall ( ForeignCall(..), CCallSpec(..),
- isDynamicTarget, isCasmTarget )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
import StgSyn ( StgOp(..) )
import CoreSyn ( AltCon(..) )
import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
returnFlt ( (tag, alt_heres), alt_tops )
flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
- | is_dynamic -- Emit a typedef if its a dynamic call
- || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
+ | is_dynamic -- Emit a typedef if its a dynamic call
+ || (opt_EmitCExternDecls) -- or we want extern decls
= returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
where
is_dynamic = isDynamicTarget target
call_str tgt
= case tgt of
- CasmTarget str -> unpackFS str
StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
( Literal(..) -- Exported to ParseIface
, mkMachInt, mkMachWord
, mkMachInt64, mkMachWord64
- , isLitLitLit, maybeLitLit, litSize
+ , litSize
, litIsDupable, litIsTrivial
, literalType, literalPrimRep
, hashLiteral
-- 'stdcall' labels.
-- Just x => "@<x>" will be appended to label
-- name when emitting asm.
-
- -- lit-lits only work for via-C compilation, hence they
- -- are deprecated. The string is emitted verbatim into
- -- the C file, and can therefore be any C expression,
- -- macro call, #defined constant etc.
- | MachLitLit FastString Type -- Type might be Addr# or Int# etc
\end{code}
-Binary instance: must do this manually, because we don't want the type
-arg of MachLitLit involved.
+Binary instance
\begin{code}
instance Binary Literal where
put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb
- put_ bh (MachLitLit ak _) = do putByte bh 10; put_ bh ak
get bh = do
h <- getByte bh
case h of
aj <- get bh
mb <- get bh
return (MachLabel aj mb)
- 10 -> do
- ak <- get bh
- return (MachLitLit ak (error "MachLitLit: no type"))
\end{code}
\begin{code}
Predicates
~~~~~~~~~~
\begin{code}
-isLitLitLit (MachLitLit _ _) = True
-isLitLitLit _ = False
-
-maybeLitLit (MachLitLit s t) = Just (s,t)
-maybeLitLit _ = Nothing
-
litIsTrivial :: Literal -> Bool
-- True if there is absolutely no penalty to duplicating the literal
-- c.f. CoreUtils.exprIsTrivial
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachLabel _ _) = addrPrimTy
-literalType (MachLitLit _ ty) = ty
\end{code}
\begin{code}
literalPrimRep (MachFloat _) = FloatRep
literalPrimRep (MachDouble _) = DoubleRep
literalPrimRep (MachLabel _ _) = AddrRep
-literalPrimRep (MachLitLit _ ty) = typePrimRep ty
\end{code}
cmpLit (MachFloat a) (MachFloat b) = a `compare` b
cmpLit (MachDouble a) (MachDouble b) = a `compare` b
cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b
-cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `tcCmpType` d)
cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
| otherwise = GT
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
litTag (MachLabel _ _) = _ILIT(10)
-litTag (MachLitLit _ _) = _ILIT(11)
\end{code}
Printing
Nothing -> pprHsString l
Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
- MachLitLit s ty | code_style -> ftext s
- | otherwise -> parens (hsep [ptext SLIT("__litlit"),
- pprHsString s,
- pprParendType ty])
-
-- negative floating literals in code style need parentheses to avoid
-- interacting with surrounding syntax.
code_rational d | d < 0 = parens (rational d)
hashLiteral (MachFloat r) = hashRational r
hashLiteral (MachDouble r) = hashRational r
hashLiteral (MachLabel s _) = hashFS s
-hashLiteral (MachLitLit s _) = hashFS s
hashRational :: Rational -> Int
hashRational r = hashInteger (numerator r)
-> [StgArg] -- Args
-> FCode (Id, CgIdInfo)
cgTopRhsCon id con args
- = ASSERT( not (isDllConApp con args) ) -- checks for litlit args too
+ = ASSERT( not (isDllConApp con args) )
ASSERT( args `lengthIs` dataConRepArity con )
-- LAY IT OUT
couldBeSmallEnoughToInline,
certainlyWillInline,
- okToUnfoldInHiFile,
callSiteInline
) where
opt_UF_UseThreshold,
opt_UF_FunAppDiscount,
opt_UF_KeenessFactor,
- opt_UF_DearOp, opt_UnfoldCasms,
+ opt_UF_DearOp,
DynFlags, DynFlag(..), dopt
)
import CoreSyn
isFCallId_maybe, globalIdDetails
)
import DataCon ( isUnboxedTupleCon )
-import Literal ( isLitLitLit, litSize )
+import Literal ( litSize )
import PrimOp ( primOpIsDupable, primOpOutOfLine )
-import ForeignCall ( okToExposeFCall )
import IdInfo ( OccInfo(..), GlobalIdDetails(..) )
import Type ( isUnLiftedType )
import PrelNames ( hasKey, buildIdKey, augmentIdKey )
= False
\end{code}
-@okToUnfoldInHifile@ is used when emitting unfolding info into an interface
-file to determine whether an unfolding candidate really should be unfolded.
-The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
-into interface files.
-
-The reason for inlining expressions containing _casm_s into interface files
-is that these fragments of C are likely to mention functions/#defines that
-will be out-of-scope when inlined into another module. This is not an
-unfixable problem for the user (just need to -#include the approp. header
-file), but turning it off seems to the simplest thing to do.
-
-\begin{code}
-okToUnfoldInHiFile :: CoreExpr -> Bool
-okToUnfoldInHiFile e = opt_UnfoldCasms || go e
- where
- -- Race over an expression looking for CCalls..
- go (Var v) = case isFCallId_maybe v of
- Just fcall -> okToExposeFCall fcall
- Nothing -> True
- go (Lit lit) = not (isLitLitLit lit)
- go (App fun arg) = go fun && go arg
- go (Lam _ body) = go body
- go (Let binds body) = and (map go (body :rhssOfBind binds))
- go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts)) &&
- not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ])
- go (Note _ body) = go body
- go (Type _) = True
-\end{code}
-
-
%************************************************************************
%* *
\subsection{callSiteInline}
import VarEnv
import Name ( hashName, isDllName )
import Literal ( hashLiteral, literalType, litIsDupable,
- litIsTrivial, isZeroLit, isLitLitLit )
+ litIsTrivial, isZeroLit )
import DataCon ( DataCon, dataConRepArity, dataConArgTys,
isExistentialDataCon, dataConTyCon, dataConName )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
%* *
%************************************************************************
-Top-level constructor applications can usually be allocated
-statically, but they can't if
- a) the constructor, or any of the arguments, come from another DLL
- b) any of the arguments are LitLits
-(because we can't refer to static labels in other DLLs).
+Top-level constructor applications can usually be allocated
+statically, but they can't if the constructor, or any of the
+arguments, come from another DLL (because we can't refer to static
+labels in other DLLs).
If this happens we simply make the RHS into an updatable thunk,
and 'exectute' it rather than allocating it statically.
is_static in_arg (Note (SCC _) e) = False
is_static in_arg (Note _ e) = is_static in_arg e
-
-is_static in_arg (Lit lit) = not (isLitLitLit lit)
- -- lit-lit arguments cannot be used in static constructors either.
- -- (litlits are deprecated, so I'm not going to bother cleaning up this infelicity --SDM).
+is_static in_arg (Lit lit) = True
is_static in_arg other_expr = go other_expr 0
where
%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
-\section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
+\section[DsCCall]{Desugaring C calls}
\begin{code}
module DsCCall
dsCCall :: CLabelString -- C routine to invoke
-> [CoreExpr] -- Arguments (desugared)
-> Safety -- Safety of the call
- -> Bool -- True <=> really a "_casm_"
-> Type -- Type of the result: IO t
-> DsM CoreExpr
-dsCCall lbl args may_gc is_asm result_ty
+dsCCall lbl args may_gc result_ty
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
boxResult [] id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq ->
let
- target | is_asm = CasmTarget lbl
- | otherwise = StaticTarget lbl
+ target = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
in
returnDs (bindNonRec y_id y_core $
Lam x_id (mkApps core_op [Var x_id, Var y_id]))
-dsExpr (HsCCall lbl args may_gc is_asm result_ty)
- = mapDs dsExpr args `thenDs` \ core_args ->
- dsCCall lbl core_args may_gc is_asm result_ty
- -- dsCCall does all the unboxification, etc.
-
dsExpr (HsSCC cc expr)
= dsExpr expr `thenDs` \ core_expr ->
getModuleDs `thenDs` \ mod_name ->
StdCallConv -> Just sz_args
_ -> Nothing
in
- dsCCall adjustor adj_args PlayRisky False io_res_ty `thenDs` \ ccall_adj ->
+ dsCCall adjustor adj_args PlayRisky io_res_ty `thenDs` \ ccall_adj ->
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
let ccall_adj_ty = exprType ccall_adj
ccall_io_adj = mkLams [stbl_value] $
repFromThenTo ds1 ds2 ds3
repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
-repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__"
repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
repE (HsBracketOut _ _) =
panic "DsMeta.repE: Can't represent Oxford brackets"
import {-# SOURCE #-} DsExpr ( dsExpr )
import DsMonad
-import DsCCall ( resultWrapper )
import DsUtils
import HsSyn ( HsLit(..), Pat(..), HsExpr(..) )
import Unique ( hasKey )
import Literal ( mkMachInt, Literal(..) )
import Maybes ( catMaybes )
-import Type ( isUnLiftedType )
import Panic ( panic, assertPanic )
-import Maybe ( isJust )
import Ratio ( numerator, denominator )
\end{code}
dsLit (HsIntPrim i) = returnDs (mkIntLit i)
dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
-dsLit (HsLitLit str ty)
- = resultWrapper ty `thenDs` \ (maybe_ty, wrap_fn) ->
- ASSERT( isJust maybe_ty )
- let (Just rep_ty) = maybe_ty in
- returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
dsLit (HsRat r ty)
= mkIntegerExpr (numerator r) `thenDs` \ num ->
mk_core_lit (HsStringPrim s) = MachStr s
mk_core_lit (HsFloatPrim f) = MachFloat f
mk_core_lit (HsDoublePrim d) = MachDouble d
- mk_core_lit (HsLitLit s ty) = ASSERT(isUnLiftedType ty)
- MachLitLit s ty
mk_core_lit other = panic "matchLiterals:mk_core_lit:unhandled"
\end{code}
import CoreSyn
import CostCentre ( pprCostCentreCore )
import NewDemand ( StrictSig, pprIfaceStrictSig )
-import Literal ( Literal, maybeLitLit )
+import Literal ( Literal )
import ForeignCall ( ForeignCall )
import DataCon ( dataConTyCon, dataConSourceArity )
import TyCon ( isTupleTyCon, tupleTyConBoxity )
| UfLet (UfBinding name) (UfExpr name)
| UfNote (UfNote name) (UfExpr name)
| UfLit Literal
- | UfLitLit FastString (HsType name)
| UfFCall ForeignCall (HsType name)
data UfNote name = UfSCC CostCentre
| UfDataAlt name
| UfTupleAlt HsTupCon
| UfLitAlt Literal
- | UfLitLitAlt FastString (HsType name)
data UfBinding name
= UfNonRec (UfBinder name)
\begin{code}
toUfExpr :: CoreExpr -> UfExpr Name
toUfExpr (Var v) = toUfVar v
-toUfExpr (Lit l) = case maybeLitLit l of
- Just (s,ty) -> UfLitLit s (toHsType ty)
- Nothing -> UfLit l
+toUfExpr (Lit l) = UfLit l
toUfExpr (Type ty) = UfType (toHsType ty)
toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
toUfExpr (App f a) = toUfApp f [a]
where
tc = dataConTyCon dc
-toUfCon (LitAlt l) = case maybeLitLit l of
- Just (s,ty) -> UfLitLitAlt s (toHsType ty)
- Nothing -> UfLitAlt l
+toUfCon (LitAlt l) = UfLitAlt l
toUfCon DEFAULT = UfDefault
---------------------
pprUfExpr add_par (UfVar v) = ppr v
pprUfExpr add_par (UfLit l) = ppr l
-pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
instance Outputable name => Outputable (UfConAlt name) where
ppr UfDefault = text "__DEFAULT"
ppr (UfLitAlt l) = ppr l
- ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
ppr (UfDataAlt d) = ppr d
instance Outputable name => Outputable (UfBinder name) where
eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
eq_ufExpr env (UfVar v1) (UfVar v2) = eq_ufVar env v1 v2
eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2
-eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
eq_ufExpr env (UfFCall c1 ty1) (UfFCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2
eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2
eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2
eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2
-eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
eq_ufConAlt env _ _ = False
\end{code}
pprLib lib <> ppr lbl
pprCEntity header lib (CFunction (DynamicTarget)) =
ptext SLIT("dynamic")
- pprCEntity header lib (CFunction (CasmTarget _)) =
- panic "HsDecls.pprCEntity: malformed C function target"
pprCEntity _ _ (CWrapper) = ptext SLIT("wrapper")
--
pprLib lib | nullFastString lib = empty
import HsImpExp ( isOperator, pprHsVar )
-- others:
-import ForeignCall ( Safety )
import PprType ( pprParendType )
import Type ( Type )
import Var ( TyVar, Id )
import Name ( Name )
-import NameSet ( FreeVars )
import DataCon ( DataCon )
-import CStrings ( CLabelString, pprCLabelString )
import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) )
import SrcLoc ( SrcLoc )
import Outputable
(HsExpr id) -- (typechecked, of course)
(ArithSeqInfo id)
- | HsCCall CLabelString -- call into the C world; string is
- [HsExpr id] -- the C function; exprs are the
- -- arguments to pass.
- Safety -- True <=> might cause Haskell
- -- garbage-collection (must generate
- -- more paranoid code)
- Bool -- True <=> it's really a "casm"
- -- NOTE: this CCall is the *boxed*
- -- version; the desugarer will convert
- -- it into the unboxed "ccall#".
- PostTcType -- The result type; will be *bottom*
- -- until the typechecker gets ahold of it
-
| HsSCC FastString -- "set cost centre" (_scc_) annotation
(HsExpr id) -- expr whose cost is to be measured
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e
-ppr_expr (HsCCall fun args _ is_asm result_ty)
- = hang (if is_asm
- then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''")
- else ptext SLIT("_ccall_") <+> pprCLabelString fun)
- 4 (sep (map pprParendExpr args))
-
ppr_expr (HsSCC lbl expr)
= sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ]
-- (overloaded literals are done with HsOverLit)
| HsFloatPrim Rational -- Unboxed Float
| HsDoublePrim Rational -- Unboxed Double
- | HsLitLit FastString PostTcType -- to pass ``literal literals'' through to C
- -- also: "overloaded" type; but
- -- must resolve to boxed-primitive!
- -- The Type in HsLitLit is needed when desuaring;
- -- before the typechecker it's just an error value
instance Eq HsLit where
(HsChar x1) == (HsChar x2) = x1==x2
(HsRat x1 _) == (HsRat x2 _) = x1==x2
(HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2
(HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2
- (HsLitLit x1 _) == (HsLitLit x2 _) = x1==x2
lit1 == lit2 = False
data HsOverLit -- An overloaded literal
ppr (HsFloatPrim f) = rational f <> char '#'
ppr (HsDoublePrim d) = rational d <> text "##"
ppr (HsIntPrim i) = integer i <> char '#'
- ppr (HsLitLit s _) = hcat [text "``", ftext s, text "''"]
instance Outputable HsOverLit where
ppr (HsIntegral i _) = integer i
ppr (HsFractional f _) = rational f
\end{code}
-
-
put_ bh (UfLit ap) = do
putByte bh 8
put_ bh ap
- put_ bh (UfLitLit aq ar) = do
- putByte bh 9
- put_ bh aq
- put_ bh ar
put_ bh (UfFCall as at) = do
- putByte bh 10
+ putByte bh 9
put_ bh as
put_ bh at
get bh = do
return (UfNote an ao)
8 -> do ap <- get bh
return (UfLit ap)
- 9 -> do aq <- get bh
- ar <- get bh
- return (UfLitLit aq ar)
_ -> do as <- get bh
at <- get bh
return (UfFCall as at)
put_ bh (UfLitAlt ac) = do
putByte bh 3
put_ bh ac
- put_ bh (UfLitLitAlt ad ae) = do
- putByte bh 4
- put_ bh ad
- put_ bh ae
get bh = do
h <- getByte bh
case h of
return (UfDataAlt aa)
2 -> do ab <- get bh
return (UfTupleAlt ab)
- 3 -> do ac <- get bh
+ _ -> do ac <- get bh
return (UfLitAlt ac)
- _ -> do ad <- get bh
- ae <- get bh
- return (UfLitLitAlt ad ae)
instance (Binary name) => Binary (UfBinding name) where
put_ bh (UfNonRec aa ab) = do
opt_DoSemiTagging,
opt_LiberateCaseThreshold,
opt_StgDoLetNoEscapes,
- opt_UnfoldCasms,
opt_CprOff,
opt_RulesOff,
opt_UnboxStrictFields,
-- Switch off CPR analysis in the new demand analyser
opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int)
opt_StgDoLetNoEscapes = lookUp FSLIT("-flet-no-escape")
-opt_UnfoldCasms = lookUp FSLIT("-funfold-casms-in-hi-file")
opt_UnboxStrictFields = lookUp FSLIT("-funbox-strict-fields")
opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int)
"fflatten",
"fsemi-tagging",
"flet-no-escape",
- "funfold-casms-in-hi-file",
"funbox-strict-fields",
"femit-extern-decls",
"fglobalise-toplev-names",
import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
import CoreSyn
-import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
+import CoreUnfold ( noUnfolding, mkTopUnfolding )
import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules )
import PprCore ( pprIdRules )
show_unfold = not bottoming_fn && -- Not necessary
not dont_inline &&
not loop_breaker &&
- rhs_is_small && -- Small enough
- okToUnfoldInHiFile rhs -- No casms etc
+ rhs_is_small -- Small enough
unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
| otherwise = emptyVarSet
%* *
%************************************************************************
-First, the dreaded @ccall@. We can't handle @casm@s.
+First, the dreaded @ccall@.
Usually, this compiles to an assignment, but when the left-hand side
is empty, we just perform the call and ignore the result.
-btw Why not let programmer use casm to provide assembly code instead
-of C code? ADR
-
ToDo: saving/restoring of volatile regs around ccalls.
JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
StaticTarget nm -> (rhs, Left nm)
DynamicTarget | notNull rhs -- an assertion
-> (tail rhs, Right (amodeToStix (head rhs)))
- CasmTarget _
- -> ncgPrimopMoan "Native code generator can't handle foreign call"
- (ppr call)
stix_args = map amodeToStix' cargs
MachNullAddr -> StInt 0
MachInt i -> StInt i
MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
- MachLitLit s _ -> litLitErr
-- dreadful, but rare.
MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
MachLabel l _ -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
amodeToStix other
= pprPanic "StixPrim.amodeToStix" (pprAmode other)
-
-litLitErr
- = ncgPrimopMoan "native code generator can't handle lit-lits" empty
\end{code}
Sizes of the CharLike and IntLike closures that are arranged as arrays
\" { lex_string_tok }
}
-<glaexts> "``" (([$graphic $whitechar] # \') | \' ([$graphic $whitechar] # \'))*
- "''" { clitlit }
-
{
-- work around bug in Alex 2.0
#if __GLASGOW_HASKELL__ < 503
| ITstdcallconv
| ITccallconv
| ITdotnet
- | ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc)
| ITmdo
| ITspecialise_prag -- Pragmas
| ITprimint Integer
| ITprimfloat Rational
| ITprimdouble Rational
- | ITlitlit FastString
-- MetaHaskell extension tokens
| ITopenExpQuote -- [| or [e|
( "with", ITwith, bit withBit),
( "rec", ITrec, bit arrowsBit),
- ( "proc", ITproc, bit arrowsBit),
-
- -- On death row
- ("_ccall_", ITccall (False, False, PlayRisky),
- bit glaExtsBit),
- ("_ccall_GC_", ITccall (False, False, PlaySafe False),
- bit glaExtsBit),
- ("_casm_", ITccall (False, True, PlayRisky),
- bit glaExtsBit),
- ("_casm_GC_", ITccall (False, True, PlaySafe False),
- bit glaExtsBit)
+ ( "proc", ITproc, bit arrowsBit)
]
reservedSymsFM = listToUFM $
where go i x | i == len = x
| otherwise = go (i+1) (x * radix + toInteger (to_int (lookAhead buf i)))
-clitlit :: Action
-clitlit loc end buf len =
- return (T loc end (ITlitlit $! lexemeToFastString (stepOnBy 2 buf) (len-4)))
-
-- -----------------------------------------------------------------------------
-- Layout processing
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.122 2003/09/08 11:52:25 simonmar Exp $
+$Id: Parser.y,v 1.123 2003/09/16 13:03:44 simonmar Exp $
Haskell grammar.
'dotnet' { T _ _ ITdotnet }
'proc' { T _ _ ITproc } -- for arrow notation extension
'rec' { T _ _ ITrec } -- for arrow notation extension
- '_ccall_' { T _ _ (ITccall (False, False, PlayRisky)) }
- '_ccall_GC_' { T _ _ (ITccall (False, False, PlaySafe False)) }
- '_casm_' { T _ _ (ITccall (False, True, PlayRisky)) }
- '_casm_GC_' { T _ _ (ITccall (False, True, PlaySafe False)) }
'{-# SPECIALISE' { T _ _ ITspecialise_prag }
'{-# SOURCE' { T _ _ ITsource_prag }
PRIMINTEGER { T _ _ (ITprimint $$) }
PRIMFLOAT { T _ _ (ITprimfloat $$) }
PRIMDOUBLE { T _ _ (ITprimdouble $$) }
- CLITLIT { T _ _ (ITlitlit $$) }
-- Template Haskell
'[|' { T _ _ ITopenExpQuote }
| srcloc 'mdo' stmtlist {% checkMDo $3 >>= \ stmts ->
return (mkHsDo MDoExpr stmts $1) }
- | '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False placeHolderType }
- | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 (PlaySafe False) False placeHolderType }
- | '_casm_' CLITLIT aexps0 { HsCCall $2 $3 PlayRisky True placeHolderType }
- | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 (PlaySafe False) True placeHolderType }
-
| scc_annot exp { if opt_SccProfilingOn
then HsSCC $1 $2
else HsPar $2 }
| PRIMSTRING { HsStringPrim $1 }
| PRIMFLOAT { HsFloatPrim $1 }
| PRIMDOUBLE { HsDoublePrim $1 }
- | CLITLIT { HsLitLit $1 placeHolderType }
srcloc :: { SrcLoc } : {% getSrcLoc }
CExportSpec(..),
CCallSpec(..),
- CCallTarget(..), isDynamicTarget, isCasmTarget,
+ CCallTarget(..), isDynamicTarget,
CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
DNCallSpec(..), DNKind(..), DNType(..),
- withDNTypes,
-
- okToExposeFCall
+ withDNTypes
) where
#include "HsVersions.h"
data CCallTarget
= StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
| DynamicTarget -- First argument (an Addr#) is the function pointer
- | CasmTarget CLabelString -- Inline C code (now seriously deprecated)
deriving( Eq )
{-! derive: Binary !-}
-isDynamicTarget, isCasmTarget :: CCallTarget -> Bool
+isDynamicTarget :: CCallTarget -> Bool
isDynamicTarget DynamicTarget = True
isDynamicTarget other = False
-
-isCasmTarget (CasmTarget _) = True
-isCasmTarget other = False
\end{code}
ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\""
ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn
- ppr_fun (CasmTarget fn) = text "__casm" <> gc_suf <+> text "``" <> pprCLabelString fn <> text "''"
\end{code}
%************************************************************************
\begin{code}
-okToExposeFCall :: ForeignCall -> Bool
--- OK to unfold a Foreign Call in an interface file
--- Yes, unless it's a _casm_
-okToExposeFCall (CCall (CCallSpec target _ _)) = not (isCasmTarget target)
-okToExposeFCall other = True
-\end{code}
-\begin{code}
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary ForeignCall where
put_ bh (CCall aa) = do
put_ bh aa
put_ bh DynamicTarget = do
putByte bh 1
- put_ bh (CasmTarget ab) = do
- putByte bh 2
- put_ bh ab
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
return (StaticTarget aa)
- 1 -> do return DynamicTarget
- _ -> do ab <- get bh
- return (CasmTarget ab)
+ _ -> do return DynamicTarget
instance Binary CCallConv where
put_ bh CCallConv = do
wiredInThingEnv,
ghcPrimExports,
- cCallableClassDecl, cReturnableClassDecl,
knownKeyNames,
-- Random other things
maybeCharLikeCon, maybeIntLikeCon,
-- Class categories
- isCcallishClass, isCreturnableClass, isNoDictClass,
- isNumericClass, isStandardClass
+ isNoDictClass, isNumericClass, isStandardClass
) where
#include "HsVersions.h"
import PrelNames ( basicKnownKeyNames,
- cCallableClassName, cReturnableClassName,
hasKey, charDataConKey, intDataConKey,
- numericClassKeys, standardClassKeys, cCallishClassKeys,
+ numericClassKeys, standardClassKeys,
noDictClassKeys )
#ifdef GHCI
import DsMeta ( templateHaskellNames )
import MkId ( mkPrimOpId, wiredInIds )
import MkId -- All of it, for re-export
import Name ( Name, nameOccName, NamedThing(..) )
-import RdrName ( mkRdrUnqual, getRdrName )
+import RdrName ( mkRdrUnqual )
import HsSyn ( HsTyVarBndr(..) )
import OccName ( mkVarOcc )
import TysPrim ( primTyCons )
import TysWiredIn ( wiredInTyCons )
-import RdrHsSyn ( mkClassDecl )
import HscTypes ( TyThing(..), implicitTyThings, TypeEnv, mkTypeEnv,
GenAvailInfo(..), RdrAvailInfo )
import Class ( Class, classKey, className )
import Type ( funTyCon, openTypeKind, liftedTypeKind )
import TyCon ( tyConName )
-import SrcLoc ( noSrcLoc )
import Util ( isIn )
\end{code}
%************************************************************************
GHC.Prim "exports" all the primops and primitive types, some
-wired-in Ids, and the CCallable & CReturnable classes.
+wired-in Ids.
\begin{code}
ghcPrimExports :: [RdrAvailInfo]
- = AvailTC cCallableOcc [ cCallableOcc ] :
- AvailTC cReturnableOcc [ cReturnableOcc ] :
- map (Avail . nameOccName . idName) ghcPrimIds ++
+ = map (Avail . nameOccName . idName) ghcPrimIds ++
map (Avail . primOpOcc) allThePrimOps ++
[ AvailTC occ [occ] |
n <- funTyCon : primTyCons, let occ = nameOccName (tyConName n)
]
- where
- cCallableOcc = nameOccName cCallableClassName
- cReturnableOcc = nameOccName cReturnableClassName
-
-cCallableClassDecl
- = mkClassDecl
- ([], getRdrName cCallableClassName, [openAlpha])
- [] -- no fds
- [] -- no sigs
- Nothing -- no mbinds
- noSrcLoc
-
-cReturnableClassDecl
- = mkClassDecl
- ([], getRdrName cReturnableClassName, [openAlpha])
- [] -- no fds
- [] -- no sigs
- Nothing -- no mbinds
- noSrcLoc
alpha = mkRdrUnqual (mkVarOcc FSLIT("a"))
openAlpha = IfaceTyVar alpha openTypeKind
%************************************************************************
\begin{code}
-isCcallishClass, isCreturnableClass, isNoDictClass,
- isNumericClass, isStandardClass :: Class -> Bool
+isNoDictClass, isNumericClass, isStandardClass :: Class -> Bool
isNumericClass clas = classKey clas `is_elem` numericClassKeys
isStandardClass clas = classKey clas `is_elem` standardClassKeys
-isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys
-isCreturnableClass clas = className clas == cReturnableClassName
isNoDictClass clas = classKey clas `is_elem` noDictClassKeys
is_elem = isIn "is_X_Class"
\end{code}
floatingClassName, -- numeric
realFracClassName, -- numeric
realFloatClassName, -- numeric
- cCallableClassName, -- mentioned, ccallish
- cReturnableClassName, -- mentioned, ccallish
dataClassName,
typeableClassName,
ordClass_RDR = nameRdrName ordClassName
enumClass_RDR = nameRdrName enumClassName
monadClass_RDR = nameRdrName monadClassName
-cCallableClass_RDR = nameRdrName cCallableClassName
-cReturnableClass_RDR = nameRdrName cReturnableClassName
map_RDR = varQual_RDR pREL_BASE_Name FSLIT("map")
append_RDR = varQual_RDR pREL_BASE_Name FSLIT("++")
bcoPrimTyConName = tcQual gHC_PRIM_Name FSLIT("BCO#") bcoPrimTyConKey
weakPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Weak#") weakPrimTyConKey
threadIdPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ThreadId#") threadIdPrimTyConKey
-cCallableClassName = clsQual gHC_PRIM_Name FSLIT("CCallable") cCallableClassKey
-cReturnableClassName = clsQual gHC_PRIM_Name FSLIT("CReturnable") cReturnableClassKey
unsafeCoerceName = wVarQual gHC_PRIM_Name FSLIT("unsafeCoerce#") unsafeCoerceIdKey
nullAddrName = wVarQual gHC_PRIM_Name FSLIT("nullAddr#") nullAddrIdKey
realFloatClassKey = mkPreludeClassUnique 15
realFracClassKey = mkPreludeClassUnique 16
showClassKey = mkPreludeClassUnique 17
-cCallableClassKey = mkPreludeClassUnique 18
-cReturnableClassKey = mkPreludeClassUnique 19
ixClassKey = mkPreludeClassUnique 20
\end{code}
[ readClassKey
]
-cCallishClassKeys =
- [ cCallableClassKey
- , cReturnableClassKey
- ]
+standardClassKeys = derivableClassKeys ++ numericClassKeys
-standardClassKeys
- = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
- --
- -- We have to have "CCallable" and "CReturnable" in the standard
- -- classes, so that if you go...
- --
- -- _ccall_ foo ... 93{-numeric literal-} ...
- --
- -- ... it can do The Right Thing on the 93.
-
-noDictClassKeys -- These classes are used only for type annotations;
- -- they are not implemented by dictionaries, ever.
- = cCallishClassKeys
+noDictClassKeys = [] -- ToDo: remove?
\end{code}
@derivableClassKeys@ is also used in checking \tr{deriving} constructs
import CoreSyn
import Id ( mkWildId )
-import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord
+import Literal ( Literal(..), mkMachInt, mkMachWord
, literalType
, word2IntLit, int2WordLit
, narrow8IntLit, narrow16IntLit, narrow32IntLit
%* *
%************************************************************************
- IMPORTANT NOTE
-
-In all these operations we might find a LitLit as an operand; that's
-why we have the catch-all Nothing case.
+ToDo: the reason these all return Nothing is because there used to be
+the possibility of an argument being a litlit. Litlits are now gone,
+so this could be cleaned up.
\begin{code}
--------------------------
litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
-litCoerce fn lit | isLitLitLit lit = Nothing
- | otherwise = Just (Lit (fn lit))
+litCoerce fn lit = Just (Lit (fn lit))
--------------------------
cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
defaultFixity, negateFixity, compareFixity )
import PrelNames ( hasKey, assertIdKey,
foldrName, buildName,
- cCallableClassName, cReturnableClassName,
enumClassName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
splitName, fstName, sndName, ioDataConName,
checkSectionPrec InfixR section op' expr' `thenM_`
returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
-rnExpr (HsCCall fun args may_gc is_casm _)
- -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
- = rnExprs args `thenM` \ (args', fvs_args) ->
- returnM (HsCCall fun args' may_gc is_casm placeHolderType,
- fvs_args `plusFV` mkFVs [cCallableClassName,
- cReturnableClassName,
- ioDataConName])
-
rnExpr (HsCoreAnn ann expr)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsCoreAnn ann expr', fvs_expr)
import TcRnMonad
import PrelNames ( gHC_PRIM_Name, gHC_PRIM )
-import PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl )
+import PrelInfo ( ghcPrimExports )
import Name ( Name {-instance NamedThing-},
nameModule, isInternalName )
import NameEnv
pi_orphan = False,
pi_usages = [],
pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]),
- pi_decls = [(1,cCallableClassDecl),
- (1,cReturnableClassDecl)],
+ pi_decls = [],
pi_fixity = [FixitySig (nameRdrName (idName seqId))
(Fixity 0 InfixR) noSrcLoc],
-- seq is infixr 0
----------------
ufExprFVs (UfVar n) = unitFV n
ufExprFVs (UfLit l) = emptyFVs
-ufExprFVs (UfLitLit l ty) = extractHsTyNames ty
ufExprFVs (UfFCall cc ty) = extractHsTyNames ty
ufExprFVs (UfType ty) = extractHsTyNames ty
ufExprFVs (UfTuple tc es) = hsTupConFVs tc `plusFV` plusFVs (map ufExprFVs es)
ufConFVs (UfDataAlt n) = unitFV n
ufConFVs (UfTupleAlt t) = hsTupConFVs t
-ufConFVs (UfLitLitAlt _ ty) = extractHsTyNames ty
ufConFVs other = emptyFVs
ufNoteFVs (UfCoerce ty) = extractHsTyNames ty
rnCoreExpr (UfLit l)
= returnM (UfLit l)
-rnCoreExpr (UfLitLit l ty)
- = rnHsType (text "litlit") ty `thenM` \ ty' ->
- returnM (UfLitLit l ty')
-
rnCoreExpr (UfFCall cc ty)
= rnHsType (text "ccall") ty `thenM` \ ty' ->
returnM (UfFCall cc ty')
rnUfCon (UfLitAlt lit)
= returnM (UfLitAlt lit)
-
-rnUfCon (UfLitLitAlt lit ty)
- = rnHsType (text "litlit") ty `thenM` \ ty' ->
- returnM (UfLitLitAlt lit ty')
\end{code}
%*********************************************************
bindPatSigTyVarsFV, bindLocalsFV, warnUnusedMatches )
import TcRnMonad
-import PrelNames( cCallishClassKeys, eqStringName, eqClassName, integralClassName,
+import PrelNames( eqStringName, eqClassName, integralClassName,
negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName,
- timesIntegerName, ratioDataConName, fromRationalName, cCallableClassName )
+ timesIntegerName, ratioDataConName, fromRationalName )
import Constants ( mAX_TUPLE_SIZE )
import TysWiredIn ( intTyCon )
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
returnM theta
where
- --Someone discovered that @CCallable@ and @CReturnable@
- -- could be used in contexts such as:
- -- foo :: CCallable a => a -> PrimIO Int
- -- Doing this utterly wrecks the whole point of introducing these
- -- classes so we specifically check that this isn't being done.
rn_pred pred = rnPred doc pred `thenM` \ pred'->
- checkErr (not (bad_pred pred'))
- (naughtyCCallContextErr pred') `thenM_`
returnM pred'
- bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys
- bad_pred other = False
-
rnPred doc (HsClassP clas tys)
= lookupOccRn clas `thenM` \ clas_name ->
litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon))
litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon))
litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon))
-litFVs (HsLitLit l bogus_ty) = returnM (unitFV cCallableClassName)
litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
-- in post-typechecker translations
bogusCharError c
-- utils
stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, getArgPrimRep,
- isLitLitArg, isDllConApp, isStgTypeArg,
+ isDllConApp, isStgTypeArg,
stgArgType, stgBinders,
pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs
import Id ( Id, idName, idPrimRep, idType, idCafInfo )
import IdInfo ( mayHaveCafRefs )
import Name ( isDllName )
-import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
+import Literal ( Literal, literalType, literalPrimRep )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, dataConName )
import CoreSyn ( AltCon )
getArgPrimRep (StgVarArg local) = idPrimRep local
getArgPrimRep (StgLitArg lit) = literalPrimRep lit
-isLitLitArg (StgLitArg lit) = isLitLitLit lit
-isLitLitArg _ = False
-
isStgTypeArg (StgTypeArg _) = True
isStgTypeArg other = False
isDllArg :: StgArg -> Bool
-- Does this argument refer to something in a different DLL?
-isDllArg (StgTypeArg v) = False
+isDllArg (StgTypeArg v) = False
isDllArg (StgVarArg v) = isDllName (idName v)
-isDllArg (StgLitArg lit) = isLitLitLit lit
+isDllArg (StgLitArg lit) = False
isDllConApp :: DataCon -> [StgArg] -> Bool
-- Does this constructor application refer to
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
isTyVarDict, isStdClassTyVarDict, isMethodFor,
- instBindingRequired, instCanBeGeneralised,
+ instBindingRequired,
zonkInst, zonkInsts,
instToId, instName,
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon,dataConSig )
import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
-import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
+import PrelInfo ( isStandardClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName )
import PprType ( pprPred, pprParendType )
import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
instBindingRequired :: Inst -> Bool
instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
instBindingRequired other = True
-
-instCanBeGeneralised :: Inst -> Bool
-instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
-instCanBeGeneralised other = True
\end{code}
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
import TysWiredIn ( boolTy )
-import PrelNames ( cCallableClassName, cReturnableClassName,
- enumFromName, enumFromThenName,
+import PrelNames ( enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName,
ioTyConName
returnM (HsProc pat' cmd' loc)
\end{code}
-
-%************************************************************************
-%* *
- Foreign calls
-%* *
-%************************************************************************
-
-The interesting thing about @ccall@ is that it is just a template
-which we instantiate by filling in details about the types of its
-argument and result (ie minimal typechecking is performed). So, the
-basic story is that we allocate a load of type variables (to hold the
-arg/result types); unify them with the args/result; and store them for
-later use.
-
-\begin{code}
-tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty
-
- = getDOpts `thenM` \ dflags ->
-
- checkTc (not (is_casm && dopt_HscLang dflags /= HscC))
- (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).",
- text "Either compile with -fvia-C, or, better, rewrite your code",
- text "to use the foreign function interface. _casm_s are deprecated",
- text "and support for them may one day disappear."])
- `thenM_`
-
- -- Get the callable and returnable classes.
- tcLookupClass cCallableClassName `thenM` \ cCallableClass ->
- tcLookupClass cReturnableClassName `thenM` \ cReturnableClass ->
- tcLookupTyCon ioTyConName `thenM` \ ioTyCon ->
- let
- new_arg_dict (arg, arg_ty)
- = newDicts (CCallOrigin (unpackFS lbl) (Just arg))
- [mkClassPred cCallableClass [arg_ty]] `thenM` \ arg_dicts ->
- returnM arg_dicts -- Actually a singleton bag
-
- result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -}
- in
-
- -- Arguments
- let tv_idxs | null args = []
- | otherwise = [1..length args]
- in
- newTyVarTys (length tv_idxs) openTypeKind `thenM` \ arg_tys ->
- tcCheckRhos args arg_tys `thenM` \ args' ->
-
- -- The argument types can be unlifted or lifted; the result
- -- type must, however, be lifted since it's an argument to the IO
- -- type constructor.
- newTyVarTy liftedTypeKind `thenM` \ result_ty ->
- let
- io_result_ty = mkTyConApp ioTyCon [result_ty]
- in
- zapExpectedTo res_ty io_result_ty `thenM_`
-
- -- Construct the extra insts, which encode the
- -- constraints on the argument and result types.
- mappM new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenM` \ ccarg_dicts_s ->
- newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenM` \ ccres_dict ->
- extendLIEs (ccres_dict ++ concat ccarg_dicts_s) `thenM_`
- returnM (HsCCall lbl args' may_gc is_casm io_result_ty)
-\end{code}
-
-
%************************************************************************
%* *
Record construction and update
\begin{code}
tcLit :: HsLit -> Expected TcRhoType -> TcM TcExpr
-tcLit (HsLitLit s _) res_ty
- = zapExpectedType res_ty `thenM` \ res_ty' ->
- tcLookupClass cCallableClassName `thenM` \ cCallableClass ->
- newDicts (LitLitOrigin (unpackFS s))
- [mkClassPred cCallableClass [res_ty']] `thenM` \ dicts ->
- extendLIEs dicts `thenM_`
- returnM (HsLit (HsLitLit s res_ty'))
-
tcLit lit res_ty
= zapExpectedTo res_ty (hsLitType lit) `thenM_`
returnM (HsLit lit)
toDNType
)
import ForeignCall ( CExportSpec(..), CCallTarget(..),
- isDynamicTarget, isCasmTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
+ isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
import CStrings ( CLabelString, isCLabelString )
import PrelNames ( hasKey, ioTyConKey )
import CmdLineOpts ( dopt_HscLang, HscLang(..) )
checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
return idecl
| otherwise -- Normal foreign import
- = checkCg (if isCasmTarget target
- then checkC else checkCOrAsmOrDotNetOrInterp) `thenM_`
+ = checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_`
checkCTarget target `thenM_`
getDOpts `thenM` \ dflags ->
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
checkCTarget (StaticTarget str)
= checkCg checkCOrAsmOrDotNetOrInterp `thenM_`
check (isCLabelString str) (badCName str)
-
-checkCTarget (CasmTarget _)
- = checkCg checkC
\end{code}
On an Alpha, with foreign export dynamic, due to a giant hack when
hsLitType (HsRat _ ty) = ty
hsLitType (HsFloatPrim f) = floatPrimTy
hsLitType (HsDoublePrim d) = doublePrimTy
-hsLitType (HsLitLit _ ty) = ty
\end{code}
%************************************************************************
= zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (HsLit (HsRat f new_ty))
-zonkExpr env (HsLit (HsLitLit lit ty))
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsLit (HsLitLit lit new_ty))
-
zonkExpr env (HsLit lit)
= returnM (HsLit lit)
zonkArithSeq env info `thenM` \ new_info ->
returnM (PArrSeqOut new_expr new_info)
-zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
- = zonkExprs env args `thenM` \ new_args ->
- zonkTcTypeToType env result_ty `thenM` \ new_result_ty ->
- returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
-
zonkExpr env (HsSCC lbl expr)
= zonkExpr env expr `thenM` \ new_expr ->
returnM (HsSCC lbl new_expr)
tcCoreExpr (UfLit lit)
= returnM (Lit lit)
--- The dreaded lit-lits are also similar, except here the type
--- is read in explicitly rather than being implicit
-tcCoreExpr (UfLitLit lit ty)
- = tcIfaceType ty `thenM` \ ty' ->
- returnM (Lit (MachLitLit lit ty'))
-
tcCoreExpr (UfFCall cc ty)
= tcIfaceType ty `thenM` \ ty' ->
newUnique `thenM` \ u ->
tcCoreExpr rhs `thenM` \ rhs' ->
returnM (LitAlt lit, [], rhs')
-tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
- = ASSERT( null names )
- tcCoreExpr rhs `thenM` \ rhs' ->
- tcIfaceType ty `thenM` \ ty' ->
- returnM (LitAlt (MachLitLit str ty'), [], rhs')
-
-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
-- others:
import Generics ( validGenericMethodType )
import TcRnMonad -- TcType, amongst others
-import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
+import PrelNames ( hasKey )
import ForeignCall ( Safety(..) )
import FunDeps ( grow )
import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred )
}}
check_inst_head dflags clas tys
- | -- CCALL CHECK
- -- A user declaration of a CCallable/CReturnable instance
- -- must be for a "boxed primitive" type.
- (clas `hasKey` cCallableClassKey
- && not (ccallable_type first_ty))
- || (clas `hasKey` cReturnableClassKey
- && not (creturnable_type first_ty))
- = failWithTc (nonBoxedPrimCCallErr clas first_ty)
-
-- If GlasgowExts then check at least one isn't a type variable
| dopt Opt_GlasgowExts dflags
= check_tyvars dflags clas tys
where
(first_ty : _) = tys
- ccallable_type ty = isFFIArgumentTy dflags PlayRisky ty
- creturnable_type ty = isFFIImportResultTy dflags ty
-
head_shape_msg = parens (text "The instance type must be of form (T a b c)" $$
text "where T is not a synonym, and a,b,c are distinct type variables")
instTypeErr pp_ty msg
= sep [ptext SLIT("Illegal instance declaration for") <+> quotes pp_ty,
nest 4 msg]
-
-nonBoxedPrimCCallErr clas inst_ty
- = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
- 4 (pprClassPred clas [inst_ty])
\end{code}
import CmdLineOpts ( opt_IrrefutableTuples )
import DataCon ( DataCon, dataConFieldLabels, dataConSourceArity )
import PrelNames ( eqStringName, eqName, geName, negateName, minusName,
- integralClassName, cCallableClassName )
+ integralClassName )
import BasicTypes ( isBoxed )
import Bag
import Outputable
%************************************************************************
\begin{code}
-tcPat tc_bndr (LitPat lit@(HsLitLit s _)) pat_ty
- -- cf tcExpr on LitLits
- = zapExpectedType pat_ty `thenM` \ pat_ty' ->
- tcLookupClass cCallableClassName `thenM` \ cCallableClass ->
- newDicts (LitLitOrigin (unpackFS s))
- [mkClassPred cCallableClass [pat_ty']] `thenM` \ dicts ->
- extendLIEs dicts `thenM_`
- returnM (LitPat (HsLitLit s pat_ty'), emptyBag, emptyBag, [])
-
tcPat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty
= zapExpectedType pat_ty `thenM` \ pat_ty' ->
unifyTauTy pat_ty' stringTy `thenM_`
(Maybe RenamedHsExpr) -- Nothing if it's the result
-- Just arg, for an argument
- | LitLitOrigin String -- the litlit
-
| UnknownOrigin -- Help! I give up...
\end{code}
pp_orig (CCallOrigin clabel (Just arg_expr))
= hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
text "namely", quotes (ppr arg_expr)]
- pp_orig (LitLitOrigin s)
- = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
pp_orig (UnknownOrigin)
= ptext SLIT("...oops -- I don't know where the overloading came from!")
\end{code}
isStdClassTyVarDict, isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
ipNamesOfInsts, ipNamesOfInst, dictPred,
- instBindingRequired, instCanBeGeneralised,
+ instBindingRequired,
newDictsFromOld, tcInstClassOp,
getDictClassTys, isTyVarDict,
instLoc, zonkInst, tidyInsts, tidyMoreInsts,
import NameSet ( NameSet, mkNameSet, elemNameSet )
import Class ( classBigSig, classKey )
import FunDeps ( oclose, grow, improve, pprEquationDoc )
-import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
+import PrelInfo ( isNumericClass )
import PrelNames ( splitName, fstName, sndName, showClassKey, eqClassKey, ordClassKey)
import HscTypes ( GhciMode(Interactive) )
= inferLoop doc (varSetElems tau_tvs)
wanted_lie `thenM` \ (qtvs, frees, binds, irreds) ->
- -- Check for non-generalisable insts
- mappM_ addCantGenErr (filter (not . instCanBeGeneralised) irreds) `thenM_`
-
extendLIEs frees `thenM_`
returnM (qtvs, binds, map instToId irreds)
| NoRhs -- Used for Insts like (CCallable f)
-- where no witness is required.
+ -- ToDo: remove?
| Rhs -- Used when there is a RHS
TcExpr -- The RHS
disambigGroup is_interactive dicts
| any std_default_class classes -- Guaranteed all standard classes
- -- See comment at the end of function for reasons as to
- -- why the defaulting mechanism doesn't apply to groups that
- -- include CCallable or CReturnable dicts.
- && not (any isCcallishClass classes)
= -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
-- SO, TRY DEFAULT TYPES IN ORDER
Left _ -> bomb_out
Right chosen_default_ty -> choose_default chosen_default_ty
- | all isCreturnableClass classes -- Default CCall stuff to ()
- = choose_default unitTy
-
| otherwise -- No defaults
= bomb_out
nest 4 (pprInstsInFull stack)]
reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
-
------------------------------------------------
-addCantGenErr inst
- = addErrTc (sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
- nest 4 (ppr inst <+> pprInstLoc (instLoc inst))])
\end{code}
projects / ghc-hetmet.git / commitdiff