Commit f16228e4 authored by simonpj's avatar simonpj

[project @ 2001-05-22 13:43:14 by simonpj]

-------------------------------------------
	Towards generalising 'foreign' declarations
	-------------------------------------------

This is a first step towards generalising 'foreign' declarations to
handle langauges other than C.  Quite a lot of files are touched,
but nothing has really changed.  Everything should work exactly as
before.

	But please be on your guard for ccall-related bugs.

Main things

Basic data types: ForeignCall.lhs
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Remove absCSyn/CallConv.lhs

* Add prelude/ForeignCall.lhs.  This defines the ForeignCall
  type and its variants

* Define ForeignCall.Safety to say whether a call is unsafe
  or not (was just a boolean).  Lots of consequential chuffing.

* Remove all CCall stuff from PrimOp, and put it in ForeignCall


Take CCallOp out of the PrimOp type (where it was always a glitch)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Add IdInfo.FCallId variant to the type IdInfo.GlobalIdDetails,
	along with predicates Id.isFCallId, Id.isFCallId_maybe

* Add StgSyn.StgOp, to sum PrimOp with FCallOp, because it
  *is* useful to sum them together in Stg and AbsC land.  If
  nothing else, it minimises changes.


Also generally rename "CCall" stuff to "FCall" where it's generic
to all foreign calls.
parent 7df73aa7
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: AbsCSyn.lhs,v 1.35 2000/10/12 15:17:07 sewardj Exp $
% $Id: AbsCSyn.lhs,v 1.36 2001/05/22 13:43:14 simonpj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
......@@ -44,10 +44,10 @@ import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
mAX_Double_REG, spRelToInt )
import CostCentre ( CostCentre, CostCentreStack )
import Literal ( mkMachInt, Literal(..) )
import ForeignCall ( CCallSpec )
import PrimRep ( PrimRep(..) )
import PrimOp ( PrimOp, CCall )
import Unique ( Unique )
import StgSyn ( SRT(..) )
import StgSyn ( StgOp, SRT(..) )
import TyCon ( TyCon )
import BitSet -- for liveness masks
import FastTypes
......@@ -117,7 +117,7 @@ stored in a mixed type location.)
| COpStmt
[CAddrMode] -- Results
PrimOp
StgOp
[CAddrMode] -- Arguments
[MagicId] -- Potentially volatile/live registers
-- (to save/restore around the call/op)
......@@ -164,7 +164,7 @@ stored in a mixed type location.)
compiling 'foreign import dynamic's)
-}
| CCallTypedef Bool {- True => use "typedef"; False => use "extern"-}
CCall [CAddrMode] [CAddrMode]
CCallSpec Unique [CAddrMode] [CAddrMode]
-- *** the next three [or so...] are DATA (those above are CODE) ***
......
......@@ -28,7 +28,8 @@ import Unique ( Unique{-instance Eq-} )
import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import CmdLineOpts ( opt_EmitCExternDecls )
import PrimOp ( PrimOp(..), CCall(..), isDynamicTarget )
import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
import StgSyn ( StgOp(..) )
import Panic ( panic )
import FastTypes
......@@ -340,16 +341,12 @@ flatAbsC (CSwitch discrim alts deflt)
= flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
returnFlt ( (tag, alt_heres), alt_tops )
flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs)
| isCandidate
= returnFlt (stmt, tdef)
| otherwise
= returnFlt (stmt, AbsCNop)
flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _ is_asm)) uniq) args _)
| is_dynamic -- Emit a typedef if its a dynamic call
|| (opt_EmitCExternDecls && not is_asm) -- or we want extern decls
= returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
where
isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
is_dynamic = isDynamicTarget target
tdef = CCallTypedef is_dynamic ccall results args
is_dynamic = isDynamicTarget target
flatAbsC stmt@(CSimultaneous abs_c)
= flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
......@@ -367,14 +364,14 @@ flatAbsC stmt@(CCallProfCtrMacro str amodes)
| otherwise = returnFlt (stmt, AbsCNop)
-- Some statements need no flattening at all:
flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(COpStmt results op args vol_regs) = returnFlt (stmt, AbsCNop)
-- Some statements only make sense at the top level, so we always float
-- them. This probably isn't necessary.
......@@ -494,11 +491,6 @@ doSimultaneously1 vertices
= or [dest1 `conflictsWith` src2 | src2 <- srcs2]
(COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
= or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
-- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
-- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
\end{code}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Calling conventions]{External calling conventions}
\begin{code}
module CallConv
(
CallConv
, pprCallConv
, callConvToInt
, stdCallConv
, cCallConv
, defaultCallConv
, callConvAttribute
) where
#include "HsVersions.h"
import Outputable
import PrimRep ( PrimRep, getPrimRepSizeInBytes )
\end{code}
\begin{code}
type CallConv = Int
pprCallConv :: CallConv -> SDoc
pprCallConv 0 = ptext SLIT("__stdcall")
pprCallConv _ = ptext SLIT("_ccall")
stdCallConv :: CallConv
stdCallConv = 0
cCallConv :: CallConv
cCallConv = 1
defaultCallConv :: CallConv
defaultCallConv = cCallConv
callConvToInt :: CallConv -> Int
callConvToInt x = x
\end{code}
Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):
ToDo: The stdcall calling convention is x86 (win32) specific,
so perhaps we should emit a warning if it's being used on other
platforms.
\begin{code}
callConvAttribute :: CallConv -> String
callConvAttribute cc
| cc == stdCallConv = "__stdcall"
| cc == cCallConv = ""
| otherwise = panic ("callConvAttribute: cannot handle" ++ showSDoc (pprCallConv cc))
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: Costs.lhs,v 1.28 2001/01/15 16:55:24 sewardj Exp $
% $Id: Costs.lhs,v 1.29 2001/05/22 13:43:14 simonpj Exp $
%
% Only needed in a GranSim setup -- HWL
% ---------------------------------------------------------------------------
......@@ -62,6 +62,7 @@ module Costs( costs,
#include "HsVersions.h"
import AbsCSyn
import StgSyn ( StgOp(..) )
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
import Panic ( trace )
......@@ -88,10 +89,6 @@ instance Num CostRes where
mapOp :: (Int -> Int) -> CostRes -> CostRes
mapOp g ( Cost (i, b, l, s, f) ) = Cost (g i, g b, g l, g s, g f)
foldrOp :: (Int -> a -> a) -> a -> CostRes -> a
foldrOp o x ( Cost (i1, b1, l1, s1, f1) ) =
i1 `o` ( b1 `o` ( l1 `o` ( s1 `o` ( f1 `o` x))))
binOp :: (Int -> Int -> Int) -> CostRes -> CostRes -> CostRes
binOp o ( Cost (i1, b1, l1, s1, f1) ) ( Cost (i2, b2, l2, s2, f2) ) =
( Cost (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) )
......@@ -185,7 +182,7 @@ costs absC =
For costing the args of this macro
see PprAbsC.lhs where args are inserted -}
COpStmt modes_res primOp modes_args _ ->
COpStmt modes_res op modes_args _ ->
{-
let
n = length modes_res
......@@ -198,9 +195,7 @@ costs absC =
-}
foldl (+) nullCosts [addrModeCosts mode Lhs | mode <- modes_res] +
foldl (+) nullCosts [addrModeCosts mode Rhs | mode <- modes_args] +
primOpCosts primOp +
if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
else nullCosts
opCosts op
CSimultaneous absC -> costs absC
......@@ -220,7 +215,7 @@ costs absC =
-- *** the next three [or so...] are DATA (those above are CODE) ***
-- as they are data rather than code they all have nullCosts -- HWL
CCallTypedef _ _ _ _ -> nullCosts
CCallTypedef _ _ _ _ _ -> nullCosts
CStaticClosure _ _ _ _ -> nullCosts
......@@ -242,6 +237,7 @@ costs absC =
_ -> trace ("Costs.costs") nullCosts
-- ---------------------------------------------------------------------------
addrModeCosts :: CAddrMode -> Side -> CostRes
......@@ -368,17 +364,24 @@ umul_costs = Cost (21,4,0,0,0) -- due to spy counts
rem_costs = Cost (30,15,0,0,0) -- due to spy counts
div_costs = Cost (30,15,0,0,0) -- due to spy counts
primOpCosts :: PrimOp -> CostRes
-- Special cases
primOpCosts (CCallOp _) = SAVE_COSTS + RESTORE_COSTS
-- don't guess costs of ccall proper
-- for exact costing use a GRAN_EXEC
-- in the C code
-- ---------------------------------------------------------------------------
opCosts :: StgOp -> CostRes
-- Usually 3 mov instructions are needed to get args and res in right place.
opCosts (StgFCallOp _ _) = SAVE_COSTS + RESTORE_COSTS
-- Don't guess costs of ccall proper
-- for exact costing use a GRAN_EXEC in the C code
opCosts (StgPrimOp primop)
= primOpCosts primop +
if primOpNeedsWrapper primop then SAVE_COSTS + RESTORE_COSTS
else nullCosts
primOpCosts :: PrimOp -> CostRes
-- Usually 3 mov instructions are needed to get args and res in right place.
primOpCosts IntMulOp = Cost (3, 1, 0, 0, 0) + umul_costs
primOpCosts IntQuotOp = Cost (3, 1, 0, 0, 0) + div_costs
primOpCosts IntRemOp = Cost (3, 1, 0, 0, 0) + rem_costs
......@@ -421,19 +424,4 @@ primOpCosts primOp
| primOp `elem` gmpOps = Cost (30, 5, 10, 10, 0) :: CostRes -- GUESS; check it
| otherwise = Cost (1, 0, 0, 0, 0)
-- ---------------------------------------------------------------------------
{- HWL: currently unused
costsByKind :: PrimRep -> Side -> CostRes
-- The following PrimKinds say that the data is already in a reg
costsByKind CharRep _ = nullCosts
costsByKind IntRep _ = nullCosts
costsByKind WordRep _ = nullCosts
costsByKind AddrRep _ = nullCosts
costsByKind FloatRep _ = nullCosts
costsByKind DoubleRep _ = nullCosts
-}
-- ---------------------------------------------------------------------------
\end{code}
......@@ -26,7 +26,7 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC,
)
import Constants ( mIN_UPD_SIZE )
import CallConv ( callConvAttribute )
import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
......@@ -45,15 +45,15 @@ import TyCon ( tyConDataCons )
import Name ( NamedThing(..) )
import DataCon ( dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper, pprCCallOp,
PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
import PrimOp ( primOpNeedsWrapper )
import ForeignCall ( ForeignCall(..), isDynamicTarget )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
addOneToUniqSet, UniqSet
)
import StgSyn ( SRT(..) )
import StgSyn ( SRT(..), StgOp(..) )
import BitSet ( intBS )
import Outputable
import GlaExts
......@@ -213,10 +213,10 @@ pprAbsC (CSwitch discrim alts deflt) c -- general case
-- Costs for addressing header of switch and cond. branching -- HWL
switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
pprAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) _
= pprCCall ccall args results vol_regs
pprAbsC stmt@(COpStmt results (StgFCallOp fcall uniq) args vol_regs) _
= pprFCall fcall uniq args results vol_regs
pprAbsC stmt@(COpStmt results op args vol_regs) _
pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _
= let
non_void_args = grab_non_void_amodes args
non_void_results = grab_non_void_amodes results
......@@ -284,7 +284,7 @@ pprAbsC (CCallProfCtrMacro op as) _
pprAbsC (CCallProfCCMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _
pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _ _) uniq results args) _
= hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
, ccall_res_ty
, fun_nm
......@@ -322,13 +322,13 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results ar
-}
fun_nm
| is_tdef = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
| otherwise = text (callConvAttribute cconv) <+> ccall_fun_ty
| is_tdef = parens (text (ccallConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
| otherwise = text (ccallConvAttribute cconv) <+> ccall_fun_ty
ccall_fun_ty =
case op_str of
DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
StaticTarget x -> pprCLabelString x
DynamicTarget -> ptext SLIT("_ccall_fun_ty") <> ppr uniq
StaticTarget x -> pprCLabelString x
ccall_res_ty =
case non_void_results of
......@@ -775,7 +775,7 @@ Amendment to the above: if we can GC, we have to:
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results vol_regs
= vcat [
char '{',
declare_local_vars, -- local var for *result*
......@@ -789,15 +789,15 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
(pp_save_context, pp_restore_context)
| may_gc = ( text "{ I_ id; SUSPEND_THREAD(id);"
, text "RESUME_THREAD(id);}"
)
| playSafe safety = ( text "{ I_ id; SUSPEND_THREAD(id);"
, text "RESUME_THREAD(id);}"
)
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
non_void_args =
let nvas = init args
in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) )
in ASSERT2 ( all non_void nvas, ppr call <+> hsep (map pprAmode args) )
nvas
-- the last argument will be the "I/O world" token (a VoidRep)
-- all others should be non-void
......@@ -820,7 +820,7 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
-- Remainder only used for ccall
fun_name = case op_str of
DynamicTarget u -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr u) <> text "%0")
DynamicTarget -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
StaticTarget st -> pprCLabelString st
ccall_str = showSDoc
......@@ -837,7 +837,6 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
| otherwise = ccall_args
ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
\end{code}
If the argument is a heap object, we need to reach inside and pull out
......@@ -1478,7 +1477,7 @@ ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
info_lbl = infoTableLabelFromCI cl_info
ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args)
ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
ppr_decls_AbsC (CCheck _ amodes code) =
ppr_decls_Amodes amodes `thenTE` \p1 ->
......
......@@ -28,6 +28,7 @@ module Id (
isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
isRecordSelector,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConId, isDataConId_maybe,
isDataConWrapId, isDataConWrapId_maybe,
isBottomingId,
......@@ -233,6 +234,14 @@ isPrimOpId_maybe id = case globalIdDetails id of
PrimOpId op -> Just op
other -> Nothing
isFCallId id = case globalIdDetails id of
FCallId call -> True
other -> False
isFCallId_maybe id = case globalIdDetails id of
FCallId call -> Just call
other -> Nothing
isDataConId id = case globalIdDetails id of
DataConId _ -> True
other -> False
......@@ -255,6 +264,7 @@ isDataConWrapId id = case globalIdDetails id of
hasNoBinding id = case globalIdDetails id of
DataConId _ -> True
PrimOpId _ -> True
FCallId _ -> True
other -> False
isImplicitId :: Id -> Bool
......@@ -264,6 +274,7 @@ isImplicitId :: Id -> Bool
isImplicitId id
= case globalIdDetails id of
RecordSelId _ -> True -- Includes dictionary selectors
FCallId _ -> True
PrimOpId _ -> True
DataConId _ -> True
DataConWrapId _ -> True
......
......@@ -88,6 +88,7 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea
Arity
)
import DataCon ( DataCon )
import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel )
import Type ( usOnce, usMany )
import Demand -- Lots of stuff
......@@ -134,6 +135,7 @@ data GlobalIdDetails
-- Id back to the data con]
| PrimOpId PrimOp -- The Id for a primitive operator
| FCallId ForeignCall -- The Id for a foreign call
| NotGlobalId -- Used as a convenient extra return value from globalIdDetails
......@@ -145,6 +147,7 @@ instance Outputable GlobalIdDetails where
ppr (DataConId _) = ptext SLIT("[DataCon]")
ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
ppr (FCallId _) = ptext SLIT("[ForeignCall]")
ppr (RecordSelId _) = ptext SLIT("[RecSel]")
\end{code}
......
......@@ -18,7 +18,7 @@ module MkId (
mkDataConId, mkDataConWrapId,
mkRecordSelId, rebuildConArgs,
mkPrimOpId, mkCCallOpId,
mkPrimOpId, mkFCallId,
-- And some particular Ids; see below for why they are wired in
wiredInIds,
......@@ -54,12 +54,10 @@ import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
import Class ( Class, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar )
import VarSet ( isEmptyVarSet )
import Name ( mkWiredInName, mkCCallName, Name )
import Name ( mkWiredInName, mkFCallName, Name )
import OccName ( mkVarOcc )
import PrimOp ( PrimOp(DataToTagOp, CCallOp),
primOpSig, mkPrimOpIdName,
CCall, pprCCallOp
)
import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
import ForeignCall ( ForeignCall )
import Demand ( wwStrict, wwPrim, mkStrictnessInfo,
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
import DataCon ( DataCon,
......@@ -631,19 +629,18 @@ mkPrimOpId prim_op
-- details of the ccall, type and all. This means that the interface
-- file reader can reconstruct a suitable Id
mkCCallOpId :: Unique -> CCall -> Type -> Id
mkCCallOpId uniq ccall ty
mkFCallId :: Unique -> ForeignCall -> Type -> Id
mkFCallId uniq fcall ty
= ASSERT( isEmptyVarSet (tyVarsOfType ty) )
-- A CCallOpId should have no free type variables;
-- when doing substitutions won't substitute over it
mkGlobalId (PrimOpId prim_op) name ty info
mkGlobalId (FCallId fcall) name ty info
where
occ_str = showSDocIface (braces (pprCCallOp ccall <+> ppr ty))
occ_str = showSDocIface (braces (ppr fcall <+> ppr ty))
-- The "occurrence name" of a ccall is the full info about the
-- ccall; it is encoded, but may have embedded spaces etc!
name = mkCCallName uniq occ_str
prim_op = CCallOp ccall
name = mkFCallName uniq occ_str
info = noCafNoTyGenIdInfo
`setCgArity` arity
......
......@@ -10,7 +10,7 @@ module Name (
-- The Name type
Name, -- Abstract
mkLocalName, mkSysLocalName, mkCCallName,
mkLocalName, mkSysLocalName, mkFCallName,
mkIPName,
mkGlobalName, mkKnownKeyGlobal, mkWiredInName,
......@@ -180,10 +180,10 @@ mkSysLocalName :: Unique -> UserFS -> Name
mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = System,
n_occ = mkVarOcc fs, n_loc = noSrcLoc }
mkCCallName :: Unique -> EncodedString -> Name
mkFCallName :: Unique -> EncodedString -> Name
-- The encoded string completely describes the ccall
mkCCallName uniq str = Name { n_uniq = uniq, n_sort = Local,
n_occ = mkCCallOcc str, n_loc = noSrcLoc }
mkFCallName uniq str = Name { n_uniq = uniq, n_sort = Local,
n_occ = mkFCallOcc str, n_loc = noSrcLoc }
mkIPName :: Unique -> OccName -> Name
mkIPName uniq occ
......
......@@ -14,7 +14,7 @@ module OccName (
OccName, -- Abstract, instance of Outputable
pprOccName,
mkOccFS, mkSysOcc, mkSysOccFS, mkCCallOcc, mkVarOcc, mkKindOccFS,
mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkVarOcc, mkKindOccFS,
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
......@@ -164,12 +164,12 @@ mkSysOccFS :: NameSpace -> EncodedFS -> OccName
mkSysOccFS occ_sp fs = ASSERT2( alreadyEncodedFS fs, ppr fs )
OccName occ_sp fs
mkCCallOcc :: EncodedString -> OccName
mkFCallOcc :: EncodedString -> OccName
-- This version of mkSysOcc doesn't check that the string is already encoded,
-- because it will be something like "{__ccall f dyn Int# -> Int#}"
-- This encodes a lot into something that then parses like an Id.
-- But then alreadyEncoded complains about the braces!
mkCCallOcc str = OccName varName (_PK_ str)
mkFCallOcc str = OccName varName (_PK_ str)
-- Kind constructors get a special function. Uniquely, they are not encoded,
-- so that they have names like '*'. This means that *even in interface files*
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgCase.lhs,v 1.51 2000/12/06 13:19:49 simonmar Exp $
% $Id: CgCase.lhs,v 1.52 2001/05/22 13:43:15 simonpj Exp $
%
%********************************************************
%* *
......@@ -56,7 +56,7 @@ import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
import Unique ( Unique, Uniquable(..), newTagUnique )
import Maybes ( maybeToBool )
import Util
import Util ( only )
import Outputable
\end{code}
......@@ -142,30 +142,32 @@ CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
doesn't clash with anything else.
\begin{code}
cgCase (StgPrimApp op args _)
cgCase (StgOpApp op args _)
live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)
| isEnumerationTyCon tycon
= getArgAmodes args `thenFC` \ arg_amodes ->
let tag_amode = case op of
TagToEnumOp -> only arg_amodes
_ -> CTemp (newTagUnique (getUnique bndr) 'C') IntRep
closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
in
case op of {
TagToEnumOp -> nopC; -- no code!
StgPrimOp TagToEnumOp -- No code!
-> returnFC (only arg_amodes) ;
_ -> -- Perform the operation
let
tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
in
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
-- NB: no liveness arg
returnFC tag_amode
} `thenFC` \ tag_amode ->
_ -> -- Perform the operation
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
absC (COpStmt [tag_amode] op
arg_amodes -- note: no liveness arg
vol_regs)
} `thenC`
let
closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep)
tag_amode PtrRep)
PtrRep
in
-- bind the default binder if necessary
-- Bind the default binder if necessary
-- The deadness info is set by StgVarInfo
(if (isDeadBinder bndr)
then nopC
......@@ -185,9 +187,9 @@ cgCase (StgPrimApp op args _)
Special case #2: inline PrimOps.
\begin{code}
cgCase (StgPrimApp op args _)
cgCase (StgOpApp op@(StgPrimOp primop) args _)
live_in_whole_case live_in_alts bndr srt alts
| not (primOpOutOfLine op)
| not (primOpOutOfLine primop)
=
-- Get amodes for the arguments and results
getArgAmodes args `thenFC` \ arg_amodes ->
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgExpr.lhs,v 1.42 2001/03/13 12:50:30 simonmar Exp $
% $Id: CgExpr.lhs,v 1.43 2001/05/22 13:43:15 simonpj Exp $
%
%********************************************************
%* *
......@@ -114,13 +114,13 @@ get in a tail-call position, however, we need to actually perform the
call, so we treat it as an inline primop.
\begin{code}
cgExpr (StgPrimApp op@(CCallOp ccall) args res_ty)
cgExpr (StgOpApp op@(StgFCallOp _ _) args res_ty)
= primRetUnboxedTuple op args res_ty
-- tagToEnum# is special: we need to pull the constructor out of the table,
-- and perform an appropriate return.
cgExpr (StgPrimApp TagToEnumOp [arg] res_ty)
cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)