From f16228e47dbaf4c5eb710bf507b3b61bc5ad7122 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 22 May 2001 13:43:19 +0000 Subject: [PATCH] [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. --- ghc/compiler/absCSyn/AbsCSyn.lhs | 10 +- ghc/compiler/absCSyn/AbsCUtils.lhs | 38 +++---- ghc/compiler/absCSyn/CallConv.lhs | 59 ----------- ghc/compiler/absCSyn/Costs.lhs | 52 ++++------ ghc/compiler/absCSyn/PprAbsC.lhs | 39 ++++--- ghc/compiler/basicTypes/Id.lhs | 11 ++ ghc/compiler/basicTypes/IdInfo.lhs | 3 + ghc/compiler/basicTypes/MkId.lhs | 21 ++-- ghc/compiler/basicTypes/Name.lhs | 8 +- ghc/compiler/basicTypes/OccName.lhs | 6 +- ghc/compiler/codeGen/CgCase.lhs | 44 ++++---- ghc/compiler/codeGen/CgExpr.lhs | 18 ++-- ghc/compiler/codeGen/ClosureInfo.lhs | 10 +- ghc/compiler/coreSyn/CoreFVs.lhs | 4 - ghc/compiler/coreSyn/CoreLint.lhs | 3 - ghc/compiler/coreSyn/CorePrep.lhs | 17 ++- ghc/compiler/coreSyn/CoreUnfold.lhs | 17 +-- ghc/compiler/coreSyn/CoreUtils.lhs | 6 +- ghc/compiler/coreSyn/PprCore.lhs | 4 +- ghc/compiler/deSugar/DsCCall.lhs | 22 ++-- ghc/compiler/deSugar/DsForeign.lhs | 60 ++++++----- ghc/compiler/deSugar/DsMonad.lhs | 1 - ghc/compiler/ghci/ByteCodeGen.lhs | 26 ++--- ghc/compiler/hsSyn/HsCore.lhs | 19 ++-- ghc/compiler/hsSyn/HsDecls.lhs | 13 ++- ghc/compiler/hsSyn/HsExpr.lhs | 3 +- ghc/compiler/ilxGen/IlxGen.lhs | 38 +++---- ghc/compiler/main/HscMain.lhs | 15 +-- ghc/compiler/nativeGen/AbsCStixGen.lhs | 10 +- ghc/compiler/nativeGen/MachCode.lhs | 27 +++-- ghc/compiler/nativeGen/Stix.lhs | 6 +- ghc/compiler/nativeGen/StixInteger.lhs | 10 +- ghc/compiler/nativeGen/StixMacro.lhs | 8 +- ghc/compiler/nativeGen/StixPrim.lhs | 122 +++++++++++++--------- ghc/compiler/parser/Lex.lhs | 27 ++--- ghc/compiler/parser/ParseUtil.lhs | 11 +- ghc/compiler/parser/Parser.y | 36 +++---- ghc/compiler/prelude/ForeignCall.lhs | 176 ++++++++++++++++++++++++++++++++ ghc/compiler/prelude/PrimOp.lhs | 110 +------------------- ghc/compiler/prelude/TysWiredIn.lhs | 20 ++-- ghc/compiler/profiling/SCCfinal.lhs | 4 +- ghc/compiler/rename/ParseIface.y | 9 +- ghc/compiler/rename/RnHsSyn.lhs | 2 +- ghc/compiler/rename/RnSource.lhs | 4 +- ghc/compiler/simplStg/SRT.lhs | 8 +- ghc/compiler/simplStg/SimplStg.lhs | 4 +- ghc/compiler/simplStg/StgStats.lhs | 10 +- ghc/compiler/stgSyn/CoreToStg.lhs | 21 +--- ghc/compiler/stgSyn/StgLint.lhs | 8 +- ghc/compiler/stgSyn/StgSyn.lhs | 35 ++++++- ghc/compiler/typecheck/TcDeriv.lhs | 2 +- ghc/compiler/typecheck/TcForeign.lhs | 13 +-- ghc/compiler/typecheck/TcIfaceSig.lhs | 6 +- ghc/compiler/typecheck/TcInstDcls.lhs | 5 +- ghc/compiler/typecheck/TcMatches.lhs | 4 +- ghc/compiler/typecheck/TcRules.lhs | 2 +- ghc/compiler/typecheck/TcTyDecls.lhs | 2 +- 57 files changed, 635 insertions(+), 634 deletions(-) delete mode 100644 ghc/compiler/absCSyn/CallConv.lhs create mode 100644 ghc/compiler/prelude/ForeignCall.lhs diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 830f819..8d0a0ff 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (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) *** diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 293e0f1..c4b6684 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -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} diff --git a/ghc/compiler/absCSyn/CallConv.lhs b/ghc/compiler/absCSyn/CallConv.lhs deleted file mode 100644 index 64e4f4a..0000000 --- a/ghc/compiler/absCSyn/CallConv.lhs +++ /dev/null @@ -1,59 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index 32b948d..6031787 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -1,7 +1,7 @@ % % (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} diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index e022656..cd9064b 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -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 -> diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 8e496b3..ee5ddf6 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -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 diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 7148a65..c3ca29b 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -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} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 23376f4..5e1165c 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -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 diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 229a0e8..303e0c7 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -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 diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 95acfef..3cc7372 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -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* diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index b6a438e..d9dc5c8 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (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 -> diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index a47eb92..f4ad2a1 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (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) = ASSERT(isEnumerationTyCon tycon) getArgAmode arg `thenFC` \amode -> -- save the tag in a temporary in case amode overlaps @@ -145,14 +145,16 @@ cgExpr (StgPrimApp TagToEnumOp [arg] res_ty) tycon = tyConAppTyCon res_ty -cgExpr x@(StgPrimApp op args res_ty) - | primOpOutOfLine op = tailCallPrimOp op args +cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) + | primOpOutOfLine primop + = tailCallPrimOp primop args + | otherwise - = ASSERT(op /= SeqOp) -- can't handle SeqOp + = ASSERT(primop /= SeqOp) -- can't handle SeqOp getArgAmodes args `thenFC` \ arg_amodes -> - case (getPrimOpResultInfo op) of + case (getPrimOpResultInfo primop) of ReturnsPrim kind -> let result_amode = CReg (dataReturnConvPrim kind) in @@ -446,7 +448,7 @@ Little helper for primitives that return unboxed tuples. \begin{code} -primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code +primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code primRetUnboxedTuple op args res_ty = getArgAmodes args `thenFC` \ arg_amodes -> {- diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 467f44b..2801d45 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.46 2001/03/13 12:50:30 simonmar Exp $ +% $Id: ClosureInfo.lhs,v 1.47 2001/05/22 13:43:15 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -84,7 +84,6 @@ import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, isNullaryDataCon, dataConName ) import TyCon ( isBoxedTupleTyCon ) -import IdInfo ( ArityInfo(..) ) import Name ( Name, nameUnique, getOccName ) import OccName ( occNameUserString ) import PprType ( getTyDescription ) @@ -910,13 +909,6 @@ isToplevClosure (MkClosureInfo _ lf_info _) other -> False \end{code} -\begin{code} -isLetNoEscape :: ClosureInfo -> Bool - -isLetNoEscape (MkClosureInfo _ (LFLetNoEscape _) _) = True -isLetNoEscape _ = False -\end{code} - Label generation. \begin{code} diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 1f64700..ad25384 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -199,10 +199,6 @@ del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bnd \begin{code} -rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet -rulesSomeFreeVars interesting (Rules rules _) - = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules - ruleRhsFreeVars :: CoreRule -> VarSet ruleRhsFreeVars (BuiltinRule _) = noFVs ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index c5315ec..2fb0bd3 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -566,9 +566,6 @@ checkL False msg = addErrL msg addErrL :: Message -> LintM a addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns) -addWarnL :: Message -> LintM a -addWarnL msg loc scope errs warns = (Nothing, errs, addErr warns msg loc) - addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg -- errors or warnings, actually... they're the same type. addErr errs_so_far msg locs diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 13c642d..f068e30 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -18,15 +18,14 @@ import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy, isUnLiftedType, isUnboxedTupleType, repType, uaUTy, usOnce, usMany, seqType ) import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) ) -import PrimOp ( PrimOp(..), setCCallUnique ) -import Var ( Var, Id, setVarUnique, globalIdDetails, setGlobalIdDetails ) +import PrimOp ( PrimOp(..) ) +import Var ( Var, Id, setVarUnique ) import VarSet import VarEnv import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity, - setIdType, isPrimOpId_maybe, isLocalId, modifyIdInfo, + setIdType, isPrimOpId_maybe, isFCallId, isLocalId, hasNoBinding ) -import IdInfo ( GlobalIdDetails(..) ) import HscTypes ( ModDetails(..) ) import UniqSupply import Maybes @@ -588,13 +587,9 @@ cloneBndr env bndr fiddleCCall :: Id -> UniqSM Id fiddleCCall id - = case globalIdDetails id of - PrimOpId (CCallOp ccall) -> - -- Make a guaranteed unique name for a dynamic ccall. - getUniqueUs `thenUs` \ uniq -> - returnUs (setGlobalIdDetails id - (PrimOpId (CCallOp (setCCallUnique ccall uniq)))) - other -> returnUs id + | isFCallId id = getUniqueUs `thenUs` \ uniq -> + returnUs (id `setVarUnique` uniq) + | otherwise = returnUs id ------------------------------------------------------------------------------ -- Generating new binders diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 7db6f2d..9441a2a 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -44,11 +44,12 @@ import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial ) import Id ( Id, idType, isId, idSpecialisation, idInlinePragma, idUnfolding, - isPrimOpId_maybe, globalIdDetails + isFCallId_maybe, globalIdDetails ) import VarSet import Literal ( isLitLitLit, litSize ) -import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm ) +import PrimOp ( primOpIsDupable, primOpOutOfLine ) +import ForeignCall ( ForeignCall(..), ccallIsCasm ) import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..), isNeverInlinePrag ) @@ -299,6 +300,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr = case globalIdDetails fun of DataConId dc -> conSizeN (valArgCount args) + FCallId fc -> sizeN opt_UF_DearOp PrimOpId op -> primOpSize op (valArgCount args) -- foldr addSize (primOpSize op) (map arg_discount args) -- At one time I tried giving an arg-discount if a primop @@ -370,7 +372,6 @@ maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1 sizeZero = SizeIs (_ILIT 0) emptyBag (_ILIT 0) sizeOne = SizeIs (_ILIT 1) emptyBag (_ILIT 0) -sizeTwo = SizeIs (_ILIT 2) emptyBag (_ILIT 0) sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT 0) conSizeN n = SizeIs (_ILIT 1) emptyBag (iUnbox n +# _ILIT 1) -- Treat constructors as size 1; we are keen to expose them @@ -478,9 +479,9 @@ okToUnfoldInHiFile :: CoreExpr -> Bool okToUnfoldInHiFile e = opt_UnfoldCasms || go e where -- Race over an expression looking for CCalls.. - go (Var v) = case isPrimOpId_maybe v of - Just op -> okToUnfoldPrimOp op - Nothing -> True + 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 @@ -491,8 +492,8 @@ okToUnfoldInHiFile e = opt_UnfoldCasms || go e go (Type _) = True -- ok to unfold a PrimOp as long as it's not a _casm_ - okToUnfoldPrimOp (CCallOp ccall) = not (ccallIsCasm ccall) - okToUnfoldPrimOp _ = True + okToExposeFCall (CCall cc) = not (ccallIsCasm cc) + okToExposeFCall other = True \end{code} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 4d3ae6d..7241e08 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -49,11 +49,10 @@ import VarEnv import Name ( hashName ) import Literal ( hashLiteral, literalType, litIsDupable ) import DataCon ( DataCon, dataConRepArity ) -import PrimOp ( primOpOkForSpeculation, primOpIsCheap, - primOpIsDupable ) +import PrimOp ( primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo, mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, - isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding + isDataConId_maybe, mkSysLocal, hasNoBinding ) import IdInfo ( LBVarInfo(..), GlobalIdDetails(..), @@ -66,7 +65,6 @@ import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply ) -import Maybes ( maybeToBool ) import Outputable import TysPrim ( alphaTy ) -- Debugging only \end{code} diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 85bab12..b8c38a4 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -27,7 +27,7 @@ import Var ( isTyVar ) import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, specInfo, cprInfo, ppCprInfo, - strictnessInfo, ppStrictnessInfo, cgInfo, pprCgInfo, + strictnessInfo, ppStrictnessInfo, cgInfo, cprInfo, ppCprInfo, workerInfo, ppWorkerInfo, tyGenInfo, ppTyGenInfo @@ -356,7 +356,7 @@ ppIdInfo b info a = arityInfo info g = tyGenInfo info s = strictnessInfo info - c = cgInfo info +-- c = cgInfo info m = cprInfo info p = specInfo info \end{code} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index ee5d7d5..c03df9e 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -6,7 +6,7 @@ \begin{code} module DsCCall ( dsCCall - , mkCCall + , mkFCall , unboxArg , boxResult , resultWrapper @@ -20,11 +20,11 @@ import DsMonad import CoreUtils ( exprType, mkCoerce ) import Id ( Id, mkWildId, idType ) -import MkId ( mkCCallOpId, realWorldPrimId, mkPrimOpId ) +import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId ) import Maybes ( maybeToBool ) -import PrimOp ( CCall(..), CCallTarget(..) ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) ) import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId ) -import CallConv +import ForeignCall ( ForeignCall, CCallTarget(..) ) import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys, splitTyConApp_maybe, tyVarsOfType, mkForAllTys, isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp, @@ -86,7 +86,7 @@ follows: \begin{code} dsCCall :: CLabelString -- C routine to invoke -> [CoreExpr] -- Arguments (desugared) - -> Bool -- True <=> might cause Haskell GC + -> Safety -- Safety of the call -> Bool -- True <=> really a "_casm_" -> Type -- Type of the result: IO t -> DsM CoreExpr @@ -96,12 +96,12 @@ dsCCall lbl args may_gc is_asm result_ty boxResult [] result_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> getUniqueDs `thenDs` \ uniq -> let - the_ccall = CCall (StaticTarget lbl) is_asm may_gc cCallConv - the_prim_app = mkCCall uniq the_ccall unboxed_args ccall_result_ty + the_fcall = CCall (CCallSpec (StaticTarget lbl) CCallConv may_gc is_asm) + the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty in returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers) -mkCCall :: Unique -> CCall +mkFCall :: Unique -> ForeignCall -> [CoreExpr] -- Args -> Type -- Result type -> CoreExpr @@ -114,14 +114,14 @@ mkCCall :: Unique -> CCall -- Here we build a ccall thus -- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) -- a b s x c -mkCCall uniq the_ccall val_args res_ty - = mkApps (mkVarApps (Var the_ccall_id) tyvars) val_args +mkFCall uniq the_fcall val_args res_ty + = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args where arg_tys = map exprType val_args body_ty = (mkFunTys arg_tys res_ty) tyvars = varSetElems (tyVarsOfType body_ty) ty = mkForAllTys tyvars body_ty - the_ccall_id = mkCCallOpId uniq the_ccall ty + the_fcall_id = mkFCallId uniq the_fcall ty \end{code} \begin{code} diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 46ea86c..06faf73 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -12,12 +12,11 @@ module DsForeign ( dsForeigns ) where import CoreSyn -import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg, resultWrapper ) +import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper ) import DsMonad import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) ) import HsDecls ( extNameStatic ) -import CallConv import TcHsSyn ( TypecheckedForeignDecl ) import CoreUtils ( exprType, mkInlineMe ) import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal, @@ -34,7 +33,11 @@ import Type ( repType, splitTyConApp_maybe, Type, mkFunTys, mkForAllTys, mkTyConApp, mkFunTy, splitAppTy, applyTy, funResultTy ) -import PrimOp ( CCall(..), CCallTarget(..), dynamicTarget ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), + Safety(..), playSafe, + CCallTarget(..), dynamicTarget, + CCallConv(..), ccallConvToInt + ) import TysWiredIn ( unitTy, addrTy, stablePtrTyCon ) import TysPrim ( addrPrimTy ) import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName, @@ -99,8 +102,7 @@ dsForeigns mod_name fos = foldlDs combine ([], [], empty, empty) fos FoLabel -> True _ -> False - (FoImport uns) = imp_exp - + FoImport uns = imp_exp \end{code} Desugaring foreign imports is just the matter of creating a binding @@ -125,11 +127,11 @@ because it exposes the boxing to the call site. \begin{code} dsFImport :: Id -> Type -- Type of foreign import. - -> Bool -- True <=> cannot re-enter the Haskell RTS + -> Safety -- Whether can re-enter the Haskell RTS, do GC etc -> ExtName - -> CallConv + -> CCallConv -> DsM [Binding] -dsFImport fn_id ty unsafe ext_name cconv +dsFImport fn_id ty safety ext_name cconv = let (tvs, fun_ty) = splitForAllTys ty (arg_tys, io_res_ty) = splitFunTys fun_ty @@ -140,11 +142,11 @@ dsFImport fn_id ty unsafe ext_name cconv let work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars - -- these are the ids we pass to boxResult, which are used to decide + -- These are the ids we pass to boxResult, which are used to decide -- whether to touch# an argument after the call (used to keep -- ForeignObj#s live across a 'safe' foreign import). - maybe_arg_ids | unsafe = [] - | otherwise = work_arg_ids + maybe_arg_ids | playSafe safety = work_arg_ids + | otherwise = [] in boxResult maybe_arg_ids io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> @@ -157,8 +159,8 @@ dsFImport fn_id ty unsafe ext_name cconv -- Build the worker worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty) - the_ccall = CCall lbl False (not unsafe) cconv - the_ccall_app = mkCCall ccall_uniq the_ccall val_args ccall_result_ty + the_ccall = CCall (CCallSpec lbl cconv safety False) + the_ccall_app = mkFCall ccall_uniq the_ccall val_args ccall_result_ty work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) work_id = mkSysLocal SLIT("$wccall") work_uniq worker_ty @@ -198,7 +200,7 @@ dsFExport :: Id -> Type -- Type of foreign export. -> Module -> ExtName - -> CallConv + -> CCallConv -> Bool -- True => invoke IO action that's hanging off -- the first argument's stable pointer -> DsM ( Id -- The foreign-exported Id @@ -329,7 +331,7 @@ dsFExportDynamic :: Id -> Type -- Type of foreign export. -> Module -> ExtName - -> CallConv + -> CCallConv -> DsM (Id, [Binding], SDoc, SDoc) dsFExportDynamic i ty mod_name ext_name cconv = newSysLocalDs ty `thenDs` \ fe_id -> @@ -363,7 +365,7 @@ dsFExportDynamic i ty mod_name ext_name cconv = to be entered using an external calling convention (stdcall, ccall). -} - adj_args = [ mkIntLitInt (callConvToInt cconv) + adj_args = [ mkIntLitInt (ccallConvToInt cconv) , Var stbl_value , mkLit (MachLabel (_PK_ fe_nm)) ] @@ -371,13 +373,13 @@ dsFExportDynamic i ty mod_name ext_name cconv = -- (probably in the RTS.) adjustor = SLIT("createAdjustor") in - dsCCall adjustor adj_args False False io_res_ty `thenDs` \ ccall_adj -> + dsCCall adjustor adj_args PlayRisky False 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] $ Note (Coerce io_res_ty ccall_adj_ty) ccall_adj - in - let io_app = mkLams tvs $ + io_app = mkLams tvs $ mkLams [cback] $ stbl_app ccall_io_adj res_ty fed = (i `setInlinePragma` neverInlinePrag, io_app) @@ -389,14 +391,9 @@ dsFExportDynamic i ty mod_name ext_name cconv = where (tvs,sans_foralls) = splitForAllTys ty ([arg_ty], io_res_ty) = splitFunTys sans_foralls - Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty - export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty - ioAddrTy :: Type -- IO Addr - ioAddrTy = mkTyConApp ioTyCon [addrTy] - toCName :: Id -> String toCName i = showSDoc (pprCode CStyle (ppr (idName i))) \end{code} @@ -417,7 +414,7 @@ fexportEntry :: String -> Id -> [Type] -> Type - -> CallConv + -> CCallConv -> Bool -> (SDoc, SDoc) fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) @@ -456,9 +453,9 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) cResType | res_ty_is_unit = text "void" | otherwise = showStgType res_ty - pprCconv - | cc == cCallConv = empty - | otherwise = pprCallConv cc + pprCconv = case cc of + CCallConv -> empty + StdCallConv -> ppr cc declareResult = text "HaskellObj ret;" @@ -479,9 +476,10 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) needed by the Adjustor.c code to get the stack cleanup right. -} (proto_args, real_args) - | cc == cCallConv && isDyn = ( text "a0" : text "a_" : mkCArgNames 1 (tail args) - , head args : addrTy : tail args) - | otherwise = (mkCArgNames 0 args, args) + = case cc of + CCallConv | isDyn -> ( text "a0" : text "a_" : mkCArgNames 1 (tail args) + , head args : addrTy : tail args) + other -> (mkCArgNames 0 args, args) mkCArgNames :: Int -> [a] -> [SDoc] mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 717faad..3c783ed 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -38,7 +38,6 @@ import Type ( Type ) import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply, UniqSM, UniqSupply ) import Unique ( Unique ) -import Util ( zipWithEqual ) import Name ( Name ) import CmdLineOpts ( DynFlags ) diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 3ed33a6..d13e802 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -13,7 +13,7 @@ module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, import Outputable import Name ( Name, getName ) -import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, +import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId, idPrimRep, mkSysLocal, idName ) import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, nilOL, toOL, concatOL, fromOL ) @@ -33,7 +33,7 @@ import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, import Class ( Class, classTyCon ) import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem ) import Var ( isTyVar ) -import VarSet ( VarSet, varSetElems, unitVarSet, unionVarSet ) +import VarSet ( VarSet, varSetElems ) import PrimRep ( getPrimRepSize, isFollowableRep ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) @@ -496,11 +496,8 @@ schemeT d s p app case app of (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg) -> case isPrimOpId_maybe v of - Nothing -> Nothing - Just primop | primop == TagToEnumOp - -> Just (snd arg, extract_constr_Names t) - | otherwise - -> Nothing + Just TagToEnumOp -> Just (snd arg, extract_constr_Names t) + other -> Nothing other -> Nothing -- Extract the args (R->L) and fn @@ -692,13 +689,15 @@ pushAtom tagged d p (AnnVar v) = ASSERT(tagged) (unitOL (PUSH_TAG 0), 1) + | isFCallId v + = pprPanic "pushAtom: byte code generator can't handle CCalls" (ppr v) + | Just primop <- isPrimOpId_maybe v - = case primop of - CCallOp _ -> panic "pushAtom: byte code generator can't handle CCalls" - other -> (unitOL (PUSH_G (Right primop)), 1) + = (unitOL (PUSH_G (Right primop)), 1) | otherwise - = let str = "\npushAtom " ++ showSDocDebug (ppr v) + = let {- + str = "\npushAtom " ++ showSDocDebug (ppr v) ++ " :: " ++ showSDocDebug (pprType (idType v)) ++ ", depth = " ++ show d ++ ", tagged = " ++ show tagged ++ ", env =\n" ++ @@ -706,9 +705,7 @@ pushAtom tagged d p (AnnVar v) ++ " --> words: " ++ show (snd result) ++ "\n" ++ showSDoc (nest 4 (vcat (map ppr (fromOL (fst result))))) ++ "\nendPushAtom " ++ showSDocDebug (ppr v) - where - cmp_snd x y = compare (snd x) (snd y) - str' = if str == str then str else str + -} result = case lookupBCEnv_maybe p v of @@ -723,7 +720,6 @@ pushAtom tagged d p (AnnVar v) sz_u = untaggedIdSizeW v nwords = if tagged then sz_t else sz_u in - --trace str' result pushAtom True d p (AnnLit lit) diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 996c4e8..66d2bf5 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -31,7 +31,7 @@ import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, ) -- others: -import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe ) +import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe ) import Var ( varType, isId ) import IdInfo ( InlinePragInfo, pprInlinePragInfo, ppStrictnessInfo ) import Name ( Name, NamedThing(..), getName, toRdrName ) @@ -39,10 +39,9 @@ import RdrName ( RdrName, rdrNameOcc ) import OccName ( isTvOcc ) import CoreSyn import CostCentre ( pprCostCentreCore ) -import PrimOp ( PrimOp(CCallOp) ) import Demand ( StrictnessInfo ) import Literal ( Literal, maybeLitLit ) -import PrimOp ( CCall, pprCCallOp ) +import ForeignCall ( ForeignCall ) import DataCon ( dataConTyCon, dataConSourceArity ) import TyCon ( isTupleTyCon, tupleTyConBoxity ) import Type ( Kind ) @@ -70,7 +69,7 @@ data UfExpr name | UfNote (UfNote name) (UfExpr name) | UfLit Literal | UfLitLit FAST_STRING (HsType name) - | UfCCall CCall (HsType name) + | UfFCall ForeignCall (HsType name) data UfNote name = UfSCC CostCentre | UfCoerce (HsType name) @@ -171,10 +170,10 @@ toUfApp e as = mkUfApps (toUfExpr e) as mkUfApps = foldl (\f a -> UfApp f (toUfExpr a)) --------------------- -toUfVar v = case isPrimOpId_maybe v of - -- Ccalls has special syntax - Just (CCallOp cc) -> UfCCall cc (toHsType (idType v)) - other -> UfVar (getName v) +toUfVar v = case isFCallId_maybe v of + -- Foreign calls have special syntax + Just fcall -> UfFCall fcall (toHsType (idType v)) + other -> UfVar (getName v) \end{code} @@ -206,7 +205,7 @@ pprUfExpr :: (NamedThing name, Outputable name) => (SDoc -> SDoc) -> UfExpr name 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 (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty) +pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty) pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map ppr bndrs) @@ -323,7 +322,7 @@ eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExp 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 (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && 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_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 33ef736..3888db9 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -33,9 +33,10 @@ import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, import CoreSyn ( CoreRule(..) ) import BasicTypes ( NewOrData(..) ) import Demand ( StrictnessMark(..) ) -import CallConv ( CallConv, pprCallConv ) +import ForeignCall ( CCallConv ) -- others: +import ForeignCall ( Safety ) import Name ( NamedThing ) import FunDeps ( pprFundeps ) import Class ( FunDep, DefMeth(..) ) @@ -675,28 +676,26 @@ data ForeignDecl name = ForKind (HsType name) ExtName - CallConv + CCallConv SrcLoc instance (Outputable name) => Outputable (ForeignDecl name) where ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc) - = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+> + = ptext SLIT("foreign") <+> ppr_imp_exp <+> ppr cconv <+> ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty where (ppr_imp_exp, ppr_unsafe) = case imp_exp of FoLabel -> (ptext SLIT("label"), empty) FoExport -> (ptext SLIT("export"), empty) - FoImport us - | us -> (ptext SLIT("import"), ptext SLIT("unsafe")) - | otherwise -> (ptext SLIT("import"), empty) + FoImport us -> (ptext SLIT("import"), ppr us) data ForKind = FoLabel | FoExport - | FoImport Bool -- True => unsafe call. + | FoImport Safety data ExtName = Dynamic diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index cf7a863..153c7d7 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -16,6 +16,7 @@ import HsTypes ( HsType ) import HsImpExp ( isOperator ) -- others: +import ForeignCall ( Safety ) import Name ( Name ) import Outputable import PprType ( pprParendType ) @@ -139,7 +140,7 @@ data HsExpr id pat | HsCCall CLabelString -- call into the C world; string is [HsExpr id pat] -- the C function; exprs are the -- arguments to pass. - Bool -- True <=> might cause Haskell + Safety -- True <=> might cause Haskell -- garbage-collection (must generate -- more paranoid code) Bool -- True <=> it's really a "casm" diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index dc6119d..24c5b54 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -23,7 +23,8 @@ import TypeRep ( Type(..) ) import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys ) import Literal ( Literal(..) ) import PrelNames -- Lots of keys -import PrimOp ( PrimOp(..), CCallTarget(..),CCall(..) ) +import PrimOp ( PrimOp(..) ) +import ForeignCall ( ForeignCall(..), CCall(..), CCallTarget(..) ) import TysWiredIn ( mkTupleTy, tupleCon ) import PrimRep ( PrimRep(..) ) import Name ( nameModule, nameOccName, isGlobalName, isLocalName, NamedThing(getName) ) @@ -38,7 +39,7 @@ import Module ( Module, PackageName, ModuleName, moduleName, import UniqFM import BasicTypes ( Boxity(..) ) import CStrings ( CLabelString, pprCLabelString ) -import CallConv ( CallConv ) +import CCallConv ( CCallConv ) import Outputable import Char ( ord ) import List ( partition, elem, insertBy,any ) @@ -110,12 +111,12 @@ importsExpr :: IlxEnv -> StgExpr -> ImportsInfo -> ImportsInfo importsExpr env (StgLit _) = importsNone importsExpr env (StgApp f args) = importsVar env f.importsStgArgs env args importsExpr env (StgConApp con args) = importsDataCon env con.importsStgArgs env args -importsExpr env (StgPrimApp (CCallOp (CCall (StaticTarget c) _ _ cc)) args rty) +importsExpr env (StgOpApp (StgFCallOp (CCall (CCallSpec (StaticTarget c) cc _ _)) _) args rty) = addCCallInfo (c,cc, map stgArgType tm_args, rty) . importsStgArgs env args where (ty_args,tm_args) = splitTyArgs1 args -importsExpr env (StgPrimApp _ args res_ty) = importsType env res_ty. importsStgArgs env args +importsExpr env (StgOpApp _ args res_ty) = importsType env res_ty. importsStgArgs env args importsExpr env (StgSCC _ expr) = importsExpr env expr @@ -186,7 +187,7 @@ importsTyCon env tc | otherwise = importsName env (getName tc) . addTyConImpInfo importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC") | otherwise = addPackageImpInfo preludePackage -type StaticCCallInfo = (CLabelString,CallConv,[Type],Type) +type StaticCCallInfo = (CLabelString,CCallConv,[Type],Type) type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon, UniqFM StaticCCallInfo) -- (Packages, Modules, Datatypes, Imported CCalls) @@ -393,7 +394,7 @@ ilxExprLocals env (StgCase scrut _ _ bndr _ alts) = ilxExprLocals (ilxPlaceStgCaseScrut env) scrut ++ (if isDeadBinder bndr then [] else [(LocalId bndr,Nothing)]) ++ ilxAltsLocals env alts -ilxExprLocals env (StgPrimApp (CCallOp (CCall (StaticTarget _)_ _ _)) args _) +ilxExprLocals env (StgOpApp (StgFCallOp (CCall (CCallSpec (StaticTarget _) _ _ _)) _) args _) = concat (ilxMapPlaceArgs 0 ilxCCallArgLocals env args) ilxExprLocals _ _ = [] @@ -421,7 +422,7 @@ ilxExprClosures env (StgApp _ args) = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings ilxExprClosures env (StgConApp _ args) = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings -ilxExprClosures env (StgPrimApp _ args _) +ilxExprClosures env (StgOpApp _ args _) = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings ilxExprClosures env (StgLet bind body) = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body @@ -503,8 +504,11 @@ ilxExpr (IlxEEnv env _) (StgConApp data_con args) sequel = text " /* ilxExpr:StgConApp */ " <+> ilxConApp env data_con args $$ ilxSequel sequel -- ilxExpr eenv (StgPrimApp primop args _) sequel -ilxExpr (IlxEEnv env _) (StgPrimApp primop args ret_ty) sequel - = ilxPrimApp env primop args ret_ty $$ ilxSequel sequel +ilxExpr (IlxEEnv env _) (StgOpApp (StgFCallOp fcall) args ret_ty) sequel + = ilxFCall env fcall args ret_ty $$ ilxSequel sequel + +ilxExpr (IlxEEnv env _) (StgOpApp (StgPrimOp primop) args ret_ty) sequel + = ilxPrimOpTable primop args env $$ ilxSequel sequel --BEGIN TEMPORARY -- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t" @@ -534,9 +538,9 @@ ilxExpr eenv@(IlxEEnv env live) (StgCase (StgApp fun args) live_in_case _live_in ] -- StgCase: Special case 2 to avoid spurious branch. -ilxExpr eenv@(IlxEEnv env live) (StgCase (StgPrimApp primop args ret_ty) live_in_case _live_in_alts bndr _ alts) sequel +ilxExpr eenv@(IlxEEnv env live) (StgCase (StgOpApp (StgPrimOp primop) args ret_ty) live_in_case _live_in_alts bndr _ alts) sequel = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)), - ilxPrimApp (ilxPlaceStgCaseScrut env) primop args ret_ty, + ilxPrimOpTable primop args (ilxPlaceStgCaseScrut env), --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)), --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel ilxAlts (IlxEEnv env live_in_case) bndr alts sequel @@ -1580,7 +1584,6 @@ ilxConRef env data_con \begin{code} -ilxPrimApp env (CCallOp ccall) args ret_ty = ilxCCall env ccall args ret_ty ilxPrimApp env op args ret_ty = ilxPrimOpTable op args env @@ -2177,7 +2180,6 @@ ilxPrimOpTable op WaitReadOp -> warn_op "WaitReadOp" (simp_op (ilxOp "/* WaitReadOp skipped... */ pop")) WaitWriteOp -> warn_op "WaitWriteOp" (simp_op (ilxOp " /* WaitWriteOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) - CCallOp _ -> panic "CCallOp should already be done..." ParAtForNowOp -> warn_op "ParAtForNowOp" (simp_op (ilxOp " /* ParAtForNowOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) ParAtRelOp -> warn_op "ParAtRelOp" (simp_op (ilxOp " /* ParAtRelOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) ParAtAbsOp -> warn_op "ParAtAbsOp" (simp_op (ilxOp " /* ParAtAbsOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) @@ -2256,20 +2258,18 @@ warn_op warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ w %************************************************************************ \begin{code} - -- Call the P/Invoke stub wrapper generated in the import section. -- We eliminate voids in and around an IL C Call. -- We also do some type-directed translation for pinning Haskell-managed blobs -- of data as we throw them across the boundary. -ilxCCall env (CCall (StaticTarget c) casm gc cconv) args ret_ty = - ilxComment (text "C call <+> pprCLabelString c") <+> +ilxFCall env (CCall (CCallSpec (StaticTarget c) cconv gc casm)) args ret_ty + = ilxComment (text "C call <+> pprCLabelString c") <+> vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args), text "call" <+> retdoc <+> pprCLabelString c <+> pprTypeArgs ilxTypeR env ty_args <+> pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ] where - retdoc = - if isVoidIlxRepType ret_ty then text "void" - else ilxTypeR env (deepIlxRepType ret_ty) + retdoc | isVoidIlxRepType ret_ty = text "void" + | otherwis = ilxTypeR env (deepIlxRepType ret_ty) (ty_args,tm_args) = splitTyArgs1 args diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 52587d2..d10faa2 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -22,7 +22,7 @@ import RdrHsSyn ( RdrNameStmt ) import Type ( Type ) import Id ( Id, idName, setGlobalIdDetails ) import IdInfo ( GlobalIdDetails(VanillaGlobal) ) -import HscTypes ( InteractiveContext(..), TyThing(..) ) +import HscTypes ( InteractiveContext(..) ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) #endif @@ -71,8 +71,7 @@ import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) import OccName ( OccName ) import Name ( Name, nameModule, nameOccName, getName, isGlobalName ) import NameEnv ( emptyNameEnv, mkNameEnv ) -import Module ( Module, lookupModuleEnvByName ) -import Maybes ( orElse ) +import Module ( Module ) import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO ) @@ -621,14 +620,4 @@ initOrigNames grab names = foldl add emptyFM names add env name = addToFM env (moduleName (nameModule name), nameOccName name) name - - -initRules :: PackageRuleBase -initRules = emptyRuleBase -{- SHOULD BE (ish) - foldl add emptyVarEnv builtinRules - where - add env (name,rule) - = extendRuleBase env name rule --} \end{code} diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 150d5ea..e6c566a 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -35,7 +35,7 @@ import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) import PrimRep ( isFloatingRep, PrimRep(..) ) import StixInfo ( genCodeInfoTable, genBitmapInfoTable ) import StixMacro ( macroCode, checkCode ) -import StixPrim ( primCode, amodeToStix, amodeToStix' ) +import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' ) import Outputable ( pprPanic, ppr ) import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) import Util ( naturalMergeSortLe ) @@ -371,12 +371,15 @@ which varies depending on whether we're profiling etc. Now the PrimOps, some of which may need caller-saves register wrappers. \begin{code} + gencode (COpStmt results (StgFCallOp fcall _) args vols) + = ASSERT( null vols ) + foreignCallCode (nonVoid results) fcall (nonVoid args) - gencode (COpStmt results op args vols) + gencode (COpStmt results (StgPrimOp op) args vols) -- ToDo (ADR?): use that liveness mask | primOpNeedsWrapper op = let - saves = volsaves vols + saves = volsaves vols restores = volrestores vols in p2stix (nonVoid results) op (nonVoid args) @@ -386,7 +389,6 @@ Now the PrimOps, some of which may need caller-saves register wrappers. | otherwise = p2stix (nonVoid results) op (nonVoid args) where nonVoid = filter ((/= VoidRep) . getAmodeRep) - \end{code} Now the dreaded conditional jump. diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index f27e603..69aceae 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -19,12 +19,11 @@ import MachRegs import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, snocOL, consOL, concatOL ) import AbsCUtils ( magicIdPrimRep ) -import CallConv ( CallConv ) +import ForeignCall ( CCallConv(..) ) import CLabel ( isAsmTemp, CLabel, labelDynamic ) import Maybes ( maybeToBool, expectJust ) import PrimRep ( isFloatingRep, PrimRep(..) ) import PrimOp ( PrimOp(..) ) -import CallConv ( cCallConv, stdCallConv ) import Stix ( getNatLabelNCG, StixTree(..), StixReg(..), CodeSegment(..), DestInfo, hasDestInfo, @@ -399,7 +398,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps Double2FloatOp -> coerceFltCode x Float2DoubleOp -> coerceFltCode x - other_op -> getRegister (StCall fn cCallConv DoubleRep [x]) + other_op -> getRegister (StCall fn CCallConv DoubleRep [x]) where fn = case other_op of FloatExpOp -> SLIT("exp") @@ -505,8 +504,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) - DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) + FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y]) + DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y]) where {- ------------------------------------------------------------ Some bizarre special code for getting condition codes into @@ -672,7 +671,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps Int2DoubleOp -> coerceInt2FP DoubleRep x other_op -> - getRegister (StCall fn cCallConv DoubleRep [x]) + getRegister (StCall fn CCallConv DoubleRep [x]) where (is_float_op, fn) = case primop of @@ -781,10 +780,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps ISraOp -> shift_code (SAR L) x y {-False-} ISrlOp -> shift_code (SHR L) x y {-False-} - FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x, y]) other -> pprPanic "getRegister(x86,dyadic primop)" @@ -1027,7 +1026,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps then StPrim Float2DoubleOp [x] else x in - getRegister (StCall fn cCallConv DoubleRep [fixed_x]) + getRegister (StCall fn CCallConv DoubleRep [fixed_x]) where (is_float_op, fn) = case primop of @@ -1143,10 +1142,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps ISraOp -> trivialCode SRA x y ISrlOp -> trivialCode SRL x y - FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x, y]) other @@ -1154,7 +1153,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps (pprStixTree (StPrim primop [x, y])) where - imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y]) + imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y]) getRegister (StInd pk mem) = getAmode mem `thenNat` \ amode -> @@ -2442,7 +2441,7 @@ genCCall fn cconv kind args call = toOL ( [CALL (fn__2 tot_arg_size)] ++ - (if cconv == stdCallConv then [] else + (if cconv == StdCallConv then [] else [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) ++ [DELTA (delta + tot_arg_size)] @@ -2464,7 +2463,7 @@ genCCall fn cconv kind args = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size)) stdcallsize tot_arg_size - | cconv == stdCallConv = '@':show tot_arg_size + | cconv == StdCallConv = '@':show tot_arg_size | otherwise = "" arg_size DF = 8 diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index d3eb3dd..ac10ae2 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -29,7 +29,7 @@ module Stix ( import Ratio ( Rational ) import AbsCSyn ( node, tagreg, MagicId(..) ) -import CallConv ( CallConv, pprCallConv ) +import ForeignCall ( CCallConv ) import CLabel ( mkAsmTempLabel, CLabel, pprCLabel ) import PrimRep ( PrimRep(..) ) import PrimOp ( PrimOp ) @@ -112,7 +112,7 @@ data StixTree -- Calls to C functions - | StCall FAST_STRING CallConv PrimRep [StixTree] + | StCall FAST_STRING CCallConv PrimRep [StixTree] -- A volatile memory scratch array, which is allocated -- relative to the stack pointer. It is an array of @@ -180,7 +180,7 @@ pprStixTree t hsep (map pprStixTree ts)) StCall nm cc k args -> paren (text "Call" <+> ptext nm <+> - pprCallConv cc <+> ppr k <+> + ppr cc <+> ppr k <+> hsep (map pprStixTree args)) StScratchWord i -> text "ScratchWord" <> paren (int i) \end{code} diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index f0e9905..cd642e8 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -16,7 +16,7 @@ module StixInteger ( import {-# SOURCE #-} StixPrim ( amodeToStix ) import AbsCSyn hiding (spRel) -- bits and bobs.. -import CallConv ( cCallConv ) +import ForeignCall ( CCallConv(..) ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import Stix ( StixTree(..), StixTreeList, arrWordsHS ) @@ -56,7 +56,7 @@ gmpCompare res args@(csa1,cda1, csa2,cda2) (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1) (a4,a5,a6) = toStruct scratch2 (aa2,sa2,da2) - mpz_cmp = StCall SLIT("__gmpz_cmp") cCallConv IntRep [scratch1, scratch2] + mpz_cmp = StCall SLIT("__gmpz_cmp") CCallConv IntRep [scratch1, scratch2] r1 = StAssign IntRep result mpz_cmp in returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs) @@ -75,7 +75,7 @@ gmpCompareInt res args@(csa1,cda1, cai) da1 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1) ai = amodeToStix cai (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1) - mpz_cmp_si = StCall SLIT("__gmpz_cmp_si") cCallConv IntRep [scratch1, ai] + mpz_cmp_si = StCall SLIT("__gmpz_cmp_si") CCallConv IntRep [scratch1, ai] r1 = StAssign IntRep result mpz_cmp_si in returnUs (\xs -> a1 : a2 : a3 : r1 : xs) @@ -95,7 +95,7 @@ gmpInteger2Int res args@(csa,cda) da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda) (a1,a2,a3) = toStruct scratch1 (aa,sa,da) - mpz_get_si = StCall SLIT("__gmpz_get_si") cCallConv IntRep [scratch1] + mpz_get_si = StCall SLIT("__gmpz_get_si") CCallConv IntRep [scratch1] r1 = StAssign IntRep result mpz_get_si in returnUs (\xs -> a1 : a2 : a3 : r1 : xs) @@ -113,7 +113,7 @@ gmpInteger2Word res args@(csa,cda) da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda) (a1,a2,a3) = toStruct scratch1 (aa,sa,da) - mpz_get_ui = StCall SLIT("__gmpz_get_ui") cCallConv IntRep [scratch1] + mpz_get_ui = StCall SLIT("__gmpz_get_ui") CCallConv IntRep [scratch1] r1 = StAssign WordRep result mpz_get_ui in returnUs (\xs -> a1 : a2 : a3 : r1 : xs) diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 09cdc42..0d234b1 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -14,7 +14,7 @@ import MachRegs import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) ) import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE ) -import CallConv ( cCallConv ) +import ForeignCall ( CCallConv(..) ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import Stix @@ -76,7 +76,7 @@ macroCode UPD_CAF args w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS) a1 = StAssign PtrRep w0 ind_static_info a2 = StAssign PtrRep w1 bhptr - a3 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr] + a3 = StCall SLIT("newCAF") CCallConv VoidRep [cafptr] in returnUs (\xs -> a1 : a2 : a3 : xs) \end{code} @@ -180,7 +180,7 @@ macroCode REGISTER_IMPORT [arg] macroCode REGISTER_FOREIGN_EXPORT [arg] = returnUs ( - \xs -> StCall SLIT("getStablePtr") cCallConv VoidRep [amodeToStix arg] + \xs -> StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg] : xs ) @@ -213,7 +213,7 @@ stg_update_PAP = StCLbl mkStgUpdatePAPLabel updatePAP, stackOverflow :: StixTree updatePAP = StJump NoDestInfo stg_update_PAP -stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep [] +stackOverflow = StCall SLIT("StackOverflow") CCallConv VoidRep [] \end{code} ----------------------------------------------------------------------------- diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index d8c9e97..4a6eec2 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -23,16 +23,22 @@ import Constants ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE, import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel, mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel, mkForeignLabel ) -import CallConv ( cCallConv ) +import ForeignCall ( CCallConv(..) ) import Outputable import FastTypes #include "NCG.h" \end{code} -The main honcho here is primCode, which handles the guts of COpStmts. +The main honchos here are primCode anf foreignCallCode, which handle the guts of COpStmts. \begin{code} +foreignCallCode + :: [CAddrMode] -- results + -> ForeignCall -- op + -> [CAddrMode] -- args + -> UniqSM StixTreeList + primCode :: [CAddrMode] -- results -> PrimOp -- op @@ -40,6 +46,12 @@ primCode -> UniqSM StixTreeList \end{code} +%************************************************************************ +%* * +\subsubsection{Code for foreign calls} +%* * +%************************************************************************ + First, the dreaded @ccall@. We can't handle @casm@s. Usually, this compiles to an assignment, but when the left-hand side @@ -48,6 +60,65 @@ 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 +rather than inheriting the calling convention of the thing which we're really +calling. + +\begin{code} +foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety is_asm)) rhs + | is_asm = error "ERROR: Native code generator can't handle casm" + | not (playSafe safety) = returnUs (\xs -> ccall : xs) + + | otherwise + = save_thread_state `thenUs` \ save -> + load_thread_state `thenUs` \ load -> + getUniqueUs `thenUs` \ uniq -> + let + id = StReg (StixTemp uniq IntRep) + + suspend = StAssign IntRep id + (StCall SLIT("suspendThread") {-no:cconv-} CCallConv + IntRep [stgBaseReg]) + resume = StCall SLIT("resumeThread") {-no:cconv-} CCallConv + VoidRep [id] + in + returnUs (\xs -> save (suspend : ccall : resume : load xs)) + + where + args = map amodeCodeForCCall rhs + amodeCodeForCCall x = + let base = amodeToStix' x + in + case getAmodeRep x of + ArrayRep -> StIndex PtrRep base arrPtrsHS + ByteArrayRep -> StIndex IntRep base arrWordsHS + ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS) + _ -> base + + ccall = case lhs of + [] -> StCall fn cconv VoidRep args + [lhs] -> + let lhs' = amodeToStix lhs + pk = case getAmodeRep lhs of + FloatRep -> FloatRep + DoubleRep -> DoubleRep + other -> IntRep + in + StAssign pk lhs' (StCall fn cconv pk args) + +foreignCallCode lhs call rhs + = pprPanic "Native code generator can't handle foreign call" (ppr call) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Code for primops} +%* * +%************************************************************************ + The (MP) integer operations are a true nightmare. Since we don't have a convenient abstract way of allocating temporary variables on the (C) stack, we use the space just below HpLim for the @MP_INT@ structures, @@ -338,53 +409,6 @@ primCode ls WriteOffAddrOp_Word64 rs = primCode_WriteOffAddrOp Word64Rep l \end{code} -ToDo: saving/restoring of volatile regs around ccalls. - -JRS, 001113: always do the call of suspendThread and resumeThread as a ccall -rather than inheriting the calling convention of the thing which we're really -calling. - -\begin{code} -primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs - | is_asm = error "ERROR: Native code generator can't handle casm" - | not may_gc = returnUs (\xs -> ccall : xs) - | otherwise = - save_thread_state `thenUs` \ save -> - load_thread_state `thenUs` \ load -> - getUniqueUs `thenUs` \ uniq -> - let - id = StReg (StixTemp uniq IntRep) - - suspend = StAssign IntRep id - (StCall SLIT("suspendThread") {-no:cconv-} cCallConv - IntRep [stgBaseReg]) - resume = StCall SLIT("resumeThread") {-no:cconv-} cCallConv - VoidRep [id] - in - returnUs (\xs -> save (suspend : ccall : resume : load xs)) - - where - args = map amodeCodeForCCall rhs - amodeCodeForCCall x = - let base = amodeToStix' x - in - case getAmodeRep x of - ArrayRep -> StIndex PtrRep base arrPtrsHS - ByteArrayRep -> StIndex IntRep base arrWordsHS - ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS) - _ -> base - - ccall = case lhs of - [] -> StCall fn cconv VoidRep args - [lhs] -> - let lhs' = amodeToStix lhs - pk = case getAmodeRep lhs of - FloatRep -> FloatRep - DoubleRep -> DoubleRep - other -> IntRep - in - StAssign pk lhs' (StCall fn cconv pk args) -\end{code} DataToTagOp won't work for 64-bit archs, as it is. diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 336a1b3..353200f 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -39,6 +39,7 @@ import List ( isSuffixOf ) import IdInfo ( InlinePragInfo(..) ) import PrelNames ( mkTupNameStr ) import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck ) +import ForeignCall ( Safety(..) ) import Demand ( Demand(..) {- instance Read -} ) import UniqFM ( listToUFM, lookupUFM ) import BasicTypes ( NewOrData(..), Boxity(..) ) @@ -130,7 +131,7 @@ data Token | ITcoerce | ITinlineMe | ITinlineCall - | ITccall (Bool,Bool,Bool) -- (is_dyn, is_casm, may_gc) + | ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc) | ITdefaultbranch | ITbottom | ITinteger_lit @@ -307,10 +308,10 @@ ghcExtensionKeywordsFM = listToUFM $ ( "with", ITwith ), ( "stdcall", ITstdcallconv), ( "ccall", ITccallconv), - ("_ccall_", ITccall (False, False, False)), - ("_ccall_GC_", ITccall (False, False, True)), - ("_casm_", ITccall (False, True, False)), - ("_casm_GC_", ITccall (False, True, True)), + ("_ccall_", ITccall (False, False, PlayRisky)), + ("_ccall_GC_", ITccall (False, False, PlaySafe)), + ("_casm_", ITccall (False, True, PlayRisky)), + ("_casm_GC_", ITccall (False, True, PlaySafe)), -- interface keywords ("__interface", ITinterface), @@ -344,14 +345,14 @@ ghcExtensionKeywordsFM = listToUFM $ ("__D", ITdeprecated), ("__U", ITunfold NoInlinePragInfo), - ("__ccall", ITccall (False, False, False)), - ("__ccall_GC", ITccall (False, False, True)), - ("__dyn_ccall", ITccall (True, False, False)), - ("__dyn_ccall_GC", ITccall (True, False, True)), - ("__casm", ITccall (False, True, False)), - ("__dyn_casm", ITccall (True, True, False)), - ("__casm_GC", ITccall (False, True, True)), - ("__dyn_casm_GC", ITccall (True, True, True)), + ("__ccall", ITccall (False, False, PlayRisky)), + ("__ccall_GC", ITccall (False, False, PlaySafe)), + ("__dyn_ccall", ITccall (True, False, PlayRisky)), + ("__dyn_ccall_GC", ITccall (True, False, PlaySafe)), + ("__casm", ITccall (False, True, PlayRisky)), + ("__dyn_casm", ITccall (True, True, PlayRisky)), + ("__casm_GC", ITccall (False, True, PlaySafe)), + ("__dyn_casm_GC", ITccall (True, True, PlaySafe)), ("/\\", ITbiglam) ] diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 47b0d16..51bc199 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -38,7 +38,7 @@ import RdrHsSyn ( RdrBinding(..), ) import RdrName import PrelNames ( unitTyCon_RDR ) -import CallConv +import ForeignCall ( CCallConv(..) ) import OccName ( dataName, varName, tcClsName, occNameSpace, setOccNameSpace, occNameUserString ) import FastString ( unpackFS ) @@ -91,15 +91,6 @@ tyConToDataCon tc ---------------------------------------------------------------------------- -- Various Syntactic Checks -callConvFM :: UniqFM CallConv -callConvFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) - [ ("stdcall", stdCallConv), - ("ccall", cCallConv) --- ("pascal", pascalCallConv), --- ("fastcall", fastCallConv) - ] - checkInstType :: RdrNameHsType -> P RdrNameHsType checkInstType t = case t of diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index f83ce6f..c8aa2ce 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.64 2001/05/18 08:46:20 simonpj Exp $ +$Id: Parser.y,v 1.65 2001/05/22 13:43:17 simonpj Exp $ Haskell grammar. @@ -21,10 +21,10 @@ import RdrName import PrelNames ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, listTyCon_RDR, tupleTyCon_RDR, unitCon_RDR, nilCon_RDR, tupleCon_RDR ) +import ForeignCall ( Safety(..), CCallConv(..), defaultCCallConv ) import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName ) import SrcLoc ( SrcLoc ) import Module -import CallConv import Demand ( StrictnessMark(..) ) import CmdLineOpts ( opt_SccProfilingOn ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) ) @@ -102,10 +102,10 @@ Conflicts: 14 shift/reduce 'with' { ITwith } 'stdcall' { ITstdcallconv } 'ccall' { ITccallconv } - '_ccall_' { ITccall (False, False, False) } - '_ccall_GC_' { ITccall (False, False, True) } - '_casm_' { ITccall (False, True, False) } - '_casm_GC_' { ITccall (False, True, True) } + '_ccall_' { ITccall (False, False, PlayRisky) } + '_ccall_GC_' { ITccall (False, False, PlaySafe) } + '_casm_' { ITccall (False, True, PlayRisky) } + '_casm_GC_' { ITccall (False, True, PlaySafe) } '{-# SPECIALISE' { ITspecialise_prag } '{-# SOURCE' { ITsource_prag } @@ -372,7 +372,7 @@ topdecl :: { RdrBinding } | srcloc 'foreign' 'label' ext_name varid '::' sigtype { RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5) - defaultCallConv $1)) } + defaultCCallConv $1)) } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } @@ -462,14 +462,14 @@ deprecation :: { RdrBinding } ----------------------------------------------------------------------------- -- Foreign import/export -callconv :: { Int } - : 'stdcall' { stdCallConv } - | 'ccall' { cCallConv } - | {- empty -} { defaultCallConv } +callconv :: { CCallConv } + : 'stdcall' { StdCallConv } + | 'ccall' { CCallConv } + | {- empty -} { defaultCCallConv } -unsafe_flag :: { Bool } - : 'unsafe' { True } - | {- empty -} { False } +unsafe_flag :: { Safety } + : 'unsafe' { PlayRisky } + | {- empty -} { PlaySafe } ext_name :: { Maybe ExtName } : 'dynamic' { Just Dynamic } @@ -701,10 +701,10 @@ exp10 :: { RdrNameHsExpr } | srcloc 'do' stmtlist {% checkDo $3 `thenP` \ stmts -> returnP (HsDo DoExpr stmts $1) } - | '_ccall_' ccallid aexps0 { HsCCall $2 $3 False False cbot } - | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 True False cbot } - | '_casm_' CLITLIT aexps0 { HsCCall $2 $3 False True cbot } - | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 True True cbot } + | '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False cbot } + | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 PlaySafe False cbot } + | '_casm_' CLITLIT aexps0 { HsCCall $2 $3 PlayRisky True cbot } + | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 PlaySafe True cbot } | scc_annot exp { if opt_SccProfilingOn then HsSCC $1 $2 diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs new file mode 100644 index 0000000..f469fa3 --- /dev/null +++ b/ghc/compiler/prelude/ForeignCall.lhs @@ -0,0 +1,176 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[Foreign]{Foreign calls} + +\begin{code} +module ForeignCall ( + ForeignCall(..), + Safety(..), playSafe, + + CCallSpec(..), ccallIsCasm, + CCallTarget(..), dynamicTarget, isDynamicTarget, + CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, + + DotNetCallSpec(..) + ) where + +#include "HsVersions.h" + +import CStrings ( CLabelString, pprCLabelString ) +import Outputable +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Data types} +%* * +%************************************************************************ + +\begin{code} +data ForeignCall + = CCall CCallSpec + | DotNetCall DotNetCallSpec + deriving( Eq ) -- We compare them when seeing if an interface + -- has changed (for versioning purposes) + +-- We may need more clues to distinguish foreign calls +-- but this simple printer will do for now +instance Outputable ForeignCall where + ppr (CCall cc) = ppr cc + ppr (DotNetCall dn) = ppr dn +\end{code} + + +\begin{code} +data Safety + = PlaySafe -- Might invoke Haskell GC, or do a call back, or + -- switch threads, etc. So make sure things are + -- tidy before the call + + | PlayRisky -- None of the above can happen; the call will return + -- without interacting with the runtime system at all + deriving( Eq, Show ) + -- Show used just for Show Lex.Token, I think + +instance Outputable Safety where + ppr PlaySafe = empty + ppr PlayRisky = ptext SLIT("unsafe") + +playSafe PlaySafe = True +playSafe PlayRisky = False +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Calling C} +%* * +%************************************************************************ + +\begin{code} +data CCallSpec + = CCallSpec CCallTarget -- What to call + CCallConv -- Calling convention to use. + Safety + Bool -- True <=> really a "casm" + deriving( Eq ) + + +ccallIsCasm :: CCallSpec -> Bool +ccallIsCasm (CCallSpec _ _ _ c_asm) = c_asm +\end{code} + +The call target: + +\begin{code} +data CCallTarget + = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'. + | DynamicTarget -- First argument (an Addr#) is the function pointer + deriving( Eq ) + +isDynamicTarget DynamicTarget = True +isDynamicTarget (StaticTarget _) = False + +dynamicTarget :: CCallTarget +dynamicTarget = DynamicTarget +\end{code} + + +Stuff to do with calling convention + +\begin{code} +data CCallConv = CCallConv | StdCallConv + deriving( Eq ) + +instance Outputable CCallConv where + ppr StdCallConv = ptext SLIT("__stdcall") + ppr CCallConv = ptext SLIT("_ccall") + +defaultCCallConv :: CCallConv +defaultCCallConv = CCallConv + +ccallConvToInt :: CCallConv -> Int +ccallConvToInt StdCallConv = 0 +ccallConvToInt CCallConv = 1 +\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} +ccallConvAttribute :: CCallConv -> String +ccallConvAttribute StdCallConv = "__stdcall" +ccallConvAttribute CCallConv = "" +\end{code} + +Printing into C files: + +\begin{code} +instance Outputable CCallSpec where + ppr (CCallSpec fun cconv safety is_casm) + = hcat [ ifPprDebug callconv + , text "__", ppr_dyn + , text before , ppr_fun , after] + where + callconv = text "{-" <> ppr cconv <> text "-}" + play_safe = playSafe safety + + before + | is_casm && play_safe = "casm_GC ``" + | is_casm = "casm ``" + | play_safe = "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} + + +%************************************************************************ +%* * +\subsubsection{.NET stuff} +%* * +%************************************************************************ + +\begin{code} +data DotNetCallSpec = DotNetCallSpec + deriving( Eq ) + +instance Outputable DotNetCallSpec where + ppr DotNetCallSpec = text "DotNet!" +\end{code} diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index f96617d..66d0035 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -15,10 +15,7 @@ module PrimOp ( primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, primOpHasSideEffects, - getPrimOpResultInfo, PrimOpResultInfo(..), - - CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp, - isDynamicTarget, dynamicTarget, setCCallUnique + getPrimOpResultInfo, PrimOpResultInfo(..) ) where #include "HsVersions.h" @@ -29,19 +26,16 @@ import TysWiredIn import Demand ( wwLazy, wwPrim, wwStrict, StrictnessInfo(..) ) import Var ( TyVar ) -import CallConv ( CallConv, pprCallConv ) 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, +import TyCon ( TyCon ) +import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, splitFunTy_maybe, splitAlgTyConApp_maybe, 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 ) @@ -61,7 +55,6 @@ These are in \tr{state-interface.verb} order. -- 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 @@ -100,7 +93,6 @@ An @Enum@-derived list would be better; meanwhile... (ToDo) allThePrimOps :: [PrimOp] allThePrimOps = #include "primop-list.hs-incl" --- Doesn't include CCall, which is really a family of primops \end{code} %************************************************************************ @@ -334,7 +326,6 @@ Some PrimOps need to be called out-of-line because they either need to 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} @@ -404,7 +395,6 @@ duplicated. \begin{code} primOpHasSideEffects :: PrimOp -> Bool -primOpHasSideEffects (CCallOp _) = True #include "primop-has-side-effects.hs-incl" \end{code} @@ -413,7 +403,6 @@ any live variables that are stored in caller-saves registers. \begin{code} primOpNeedsWrapper :: PrimOp -> Bool -primOpNeedsWrapper (CCallOp _) = True #include "primop-needs-wrapper.hs-incl" \end{code} @@ -475,7 +464,6 @@ primOpSig op -- 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 @@ -525,8 +513,6 @@ data PrimOpResultInfo -- 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) @@ -552,15 +538,6 @@ commutableOp :: PrimOp -> Bool 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 @@ -569,8 +546,6 @@ 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. @@ -582,80 +557,3 @@ pprPrimOp other_op \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} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 5e10b29..7e046be 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -75,7 +75,7 @@ module TysWiredIn ( wordTy, wordTyCon, - isFFIArgumentTy, -- :: DynFlags -> Bool -> Type -> Bool + isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool isFFIImportResultTy, -- :: DynFlags -> Type -> Bool isFFIExportResultTy, -- :: Type -> Bool isFFIExternalTy, -- :: Type -> Bool @@ -97,6 +97,7 @@ import PrelNames import TysPrim -- others: +import ForeignCall ( Safety, playSafe ) import Constants ( mAX_TUPLE_SIZE ) import Module ( mkPrelModule ) import Name ( Name, nameRdrName, nameUnique, nameOccName, @@ -393,9 +394,6 @@ foreignObjTyCon foreignObjDataCon = pcDataCon foreignObjDataConName [] [] [foreignObjPrimTy] foreignObjTyCon - -isForeignObjTy :: Type -> Bool -isForeignObjTy = isTyCon foreignObjTyConKey \end{code} \begin{code} @@ -447,10 +445,10 @@ restricted set of types as arguments and results (the restricting factor being the ) \begin{code} -isFFIArgumentTy :: DynFlags -> Bool -> Type -> Bool +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool -- Checks for valid argument type for a 'foreign import' -isFFIArgumentTy dflags is_safe ty - = checkRepTyCon (legalOutgoingTyCon dflags is_safe) ty +isFFIArgumentTy dflags safety ty + = checkRepTyCon (legalOutgoingTyCon dflags safety) ty isFFIExternalTy :: Type -> Bool -- Types that are allowed as arguments of a 'foreign export' @@ -525,12 +523,10 @@ legalFEResultTyCon tc | tc == unitTyCon = True | otherwise = boxedMarshalableTyCon tc -legalOutgoingTyCon :: DynFlags -> Bool -> TyCon -> Bool +legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool -- Checks validity of types going from Haskell -> external world --- The boolean is true for a 'safe' call (when we don't want to --- pass Haskell pointers to the world) -legalOutgoingTyCon dflags be_safe tc - | be_safe && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey] +legalOutgoingTyCon dflags safety tc + | playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey] = False | otherwise = marshalableTyCon dflags tc diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 00b1921..31a90eb 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -169,8 +169,8 @@ stgMassageForProfiling mod_name us stg_binds do_expr (StgConApp con args) = boxHigherOrderArgs (\args -> StgConApp con args) args - do_expr (StgPrimApp con args res_ty) - = boxHigherOrderArgs (\args -> StgPrimApp con args res_ty) args + do_expr (StgOpApp con args res_ty) + = boxHigherOrderArgs (\args -> StgOpApp con args res_ty) args do_expr (StgSCC cc expr) -- Ha, we found a cost centre! = collectCC cc `thenMM_` diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 4a942ea..78aa477 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -43,10 +43,9 @@ import BasicTypes ( Fixity(..), FixityDirection(..), ) import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) ) import Demand ( StrictnessMark(..) ) -import CallConv ( cCallConv ) import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind ) import IdInfo ( InlinePragInfo(..) ) -import PrimOp ( CCall(..), CCallTarget(..) ) +import ForeignCall ( ForeignCall(..), CCallConv(..), CCallSpec(..), CCallTarget(..) ) import Lex import RnMonad ( ParsedIface(..), ExportItem, IfaceDeprecs ) @@ -808,12 +807,12 @@ core_aexpr : qvar_name { UfVar $1 } { let (is_dyn, is_casm, may_gc) = $2 - target | is_dyn = DynamicTarget (error "CCall dyn target bogus unique") + target | is_dyn = DynamicTarget | otherwise = StaticTarget $3 - ccall = CCall target is_casm may_gc cCallConv + ccall = CCallSpec target CCallConv may_gc is_casm in - UfCCall ccall $4 + UfFCall (CCall ccall) $4 } diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 8f01d67..13c14bc 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -189,7 +189,7 @@ hsIdInfoFVs other = emptyFVs ufExprFVs (UfVar n) = unitFV n ufExprFVs (UfLit l) = emptyFVs ufExprFVs (UfLitLit l ty) = extractHsTyNames ty -ufExprFVs (UfCCall cc 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) ufExprFVs (UfLam v e) = ufBndrFVs v (ufExprFVs e) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 65fbfd5..781e67c 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -715,9 +715,9 @@ rnCoreExpr (UfLitLit l ty) = rnHsType (text "litlit") ty `thenRn` \ ty' -> returnRn (UfLitLit l ty') -rnCoreExpr (UfCCall cc ty) +rnCoreExpr (UfFCall cc ty) = rnHsType (text "ccall") ty `thenRn` \ ty' -> - returnRn (UfCCall cc ty') + returnRn (UfFCall cc ty') rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args) = mapRn rnCoreExpr args `thenRn` \ args' -> diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs index bd5636e..46e8b4f 100644 --- a/ghc/compiler/simplStg/SRT.lhs +++ b/ghc/compiler/simplStg/SRT.lhs @@ -145,10 +145,10 @@ Expressions \begin{code} srtExpr :: SrtOffset -> StgExpr -> (StgExpr, SrtIds, SrtOffset) -srtExpr off e@(StgApp f args) = (e, [], off) -srtExpr off e@(StgLit l) = (e, [], off) -srtExpr off e@(StgConApp con args) = (e, [], off) -srtExpr off e@(StgPrimApp op args ty) = (e, [], off) +srtExpr off e@(StgApp f args) = (e, [], off) +srtExpr off e@(StgLit l) = (e, [], off) +srtExpr off e@(StgConApp con args) = (e, [], off) +srtExpr off e@(StgOpApp op args ty) = (e, [], off) srtExpr off (StgSCC cc expr) = srtExpr off expr =: \(expr, srt, off) -> diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index e0c71bb..f8652ed 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -17,14 +17,12 @@ import StgStats ( showStgStats ) import SRT ( computeSRTs ) import CmdLineOpts ( DynFlags, DynFlag(..), dopt, - opt_StgDoLetNoEscapes, StgToDo(..), dopt_StgToDo ) import Id ( Id ) import Module ( Module ) import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass ) -import UniqSupply ( mkSplitUniqSupply, splitUniqSupply, UniqSupply ) -import IO ( hPutStr, stdout ) +import UniqSupply ( mkSplitUniqSupply, splitUniqSupply ) import Outputable \end{code} diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs index e958122..824c112 100644 --- a/ghc/compiler/simplStg/StgStats.lhs +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -148,11 +148,11 @@ statRhs top (b, StgRhsClosure cc bi fv u args body) \begin{code} statExpr :: StgExpr -> StatEnv -statExpr (StgApp _ _) = countOne Applications -statExpr (StgLit _) = countOne Literals -statExpr (StgConApp _ _) = countOne ConstructorApps -statExpr (StgPrimApp _ _ _) = countOne PrimitiveApps -statExpr (StgSCC l e) = statExpr e +statExpr (StgApp _ _) = countOne Applications +statExpr (StgLit _) = countOne Literals +statExpr (StgConApp _ _) = countOne ConstructorApps +statExpr (StgOpApp _ _ _) = countOne PrimitiveApps +statExpr (StgSCC l e) = statExpr e statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body) = statBinding False{-not top-level-} binds `combineSE` diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 9772179..07acdd3 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -27,7 +27,6 @@ import VarSet import VarEnv import DataCon ( dataConWrapId ) import IdInfo ( OccInfo(..) ) -import TysPrim ( foreignObjPrimTyCon ) import Maybes ( maybeToBool ) import Name ( getOccName, isExternallyVisibleName, isDllName ) import OccName ( occNameUserString ) @@ -468,20 +467,6 @@ coreToStgExpr (Let bind body) returnLne (new_let, fvs, escs) \end{code} -If we've got a case containing a _ccall_GC_ primop, we need to -ensure that the arguments are kept live for the duration of the -call. This only an issue - -\begin{code} -isForeignObjArg :: Id -> Bool -isForeignObjArg x = isId x && isForeignObjPrimTy (idType x) - -isForeignObjPrimTy ty - = case splitTyConApp_maybe ty of - Just (tycon, _) -> tycon == foreignObjPrimTyCon - Nothing -> False -\end{code} - \begin{code} mkStgAlgAlts ty alts deflt = case alts of @@ -552,9 +537,11 @@ coreToStgApp maybe_thunk_body f args -- continuation, but it does no harm to just union the -- two regardless. + res_ty = exprType (mkApps (Var f) args) app = case globalIdDetails f of - DataConId dc -> StgConApp dc args' - PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args)) + DataConId dc -> StgConApp dc args' + PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty + FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty _other -> StgApp f args' in diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 0eda05d..72a1ffb 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -166,7 +166,13 @@ lintStgExpr e@(StgConApp con args) where con_ty = dataConRepType con -lintStgExpr e@(StgPrimApp op args _) +lintStgExpr e@(StgOpApp (StgFCallOp _ _) args res_ty) + = -- We don't have enough type information to check + -- the application; ToDo + mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys -> + returnL (Just res_ty) + +lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys -> case maybe_arg_tys of Nothing -> returnL Nothing diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 633d5be..b100b1e 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -10,7 +10,7 @@ suited to spineless tagless code generation. \begin{code} module StgSyn ( - GenStgArg(..), + GenStgArg(..), GenStgLiveVars, GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), @@ -27,6 +27,9 @@ module StgSyn ( StgBinding, StgExpr, StgRhs, StgCaseAlts, StgCaseDefault, + -- StgOp + StgOp(..), + -- SRTs SRT(..), noSRT, @@ -49,12 +52,14 @@ import VarSet ( IdSet, isEmptyVarSet ) import Id ( Id, idName, idPrimRep, idType ) import Name ( isDllName ) import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) +import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConName ) import PrimOp ( PrimOp ) import Outputable import Type ( Type ) import TyCon ( TyCon ) import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) +import Unique ( Unique ) import CmdLineOpts ( opt_SccProfilingOn ) \end{code} @@ -166,7 +171,7 @@ constructors, primitives, and literals. | StgConApp DataCon [GenStgArg occ] -- Saturated - | StgPrimApp PrimOp + | StgOpApp StgOp -- Primitive op or foreign call [GenStgArg occ] -- Saturated Type -- Result type; we need to know the result type -- so that we can assign result registers. @@ -533,6 +538,26 @@ isUpdatable Updatable = True %************************************************************************ %* * +\subsubsection{StgOp} +%* * +%************************************************************************ + +An StgOp allows us to group together PrimOps and ForeignCalls. +It's quite useful to move these around together, notably +in StgOpApp and COpStmt. + +\begin{code} +data StgOp = StgPrimOp PrimOp + + | StgFCallOp ForeignCall Unique + -- The Unique is occasionally needed by the C pretty-printer + -- (which lacks a unique supply), notably when generating a + -- typedef for foreign-export-dynamic +\end{code} + + +%************************************************************************ +%* * \subsubsection[Static Reference Tables]{@SRT@} %* * %************************************************************************ @@ -646,8 +671,8 @@ pprStgExpr (StgApp func args) pprStgExpr (StgConApp con args) = hsep [ ppr con, brackets (interppSP args)] -pprStgExpr (StgPrimApp op args _) - = hsep [ ppr op, brackets (interppSP args)] +pprStgExpr (StgOpApp op args _) + = hsep [ pprStgOp op, brackets (interppSP args)] pprStgExpr (StgLam _ bndrs body) =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"), @@ -746,6 +771,8 @@ pprStgDefault StgNoDefault = empty pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr) +pprStgOp (StgPrimOp op) = ppr op +pprStgOp (StgFCallOp op _) = ppr op \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 86084ab..95d9695 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -44,7 +44,7 @@ import TyCon ( tyConTyVars, tyConDataCons, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, TyCon ) -import Type ( TauType, ThetaType, PredType, mkTyVarTys, mkTyConApp, +import Type ( ThetaType, mkTyVarTys, mkTyConApp, isUnLiftedType, mkClassPred ) import Var ( TyVar ) import PrelNames diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index b394eef..3f133ff 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -46,6 +46,7 @@ import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy, isFFILabelTy ) import Type ( Type ) +import ForeignCall ( Safety ) import PrelNames ( hasKey, ioTyConKey ) import Outputable @@ -111,7 +112,7 @@ tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) = let i = (mkLocalId nm sig_ty) in returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc)) -tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_loc) = +tcFImport fo@(ForeignDecl nm imp_exp@(FoImport safety) hs_ty ext_nm cconv src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ @@ -125,7 +126,7 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_ in case splitFunTys t_ty of (arg_tys, res_ty) -> - checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_` + checkForeignImport (isDynamicExtName ext_nm) safety ty arg_tys res_ty `thenTc_` let i = (mkLocalId nm ty) in returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc)) @@ -161,8 +162,8 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = \begin{code} -checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM () -checkForeignImport is_dynamic is_safe ty args res +checkForeignImport :: Bool -> Safety -> Type -> [Type] -> Type -> TcM () +checkForeignImport is_dynamic safety ty args res | is_dynamic = -- * first arg has got to be an Addr case args of @@ -170,11 +171,11 @@ checkForeignImport is_dynamic is_safe ty args res (x:xs) -> getDOptsTc `thenTc` \ dflags -> check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_` - mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) xs `thenTc_` + mapTc (checkForeignArg (isFFIArgumentTy dflags safety)) xs `thenTc_` checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res | otherwise = getDOptsTc `thenTc` \ dflags -> - mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) args `thenTc_` + mapTc (checkForeignArg (isFFIArgumentTy dflags safety)) args `thenTc_` checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM () diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index b922e62..f710e45 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -27,7 +27,7 @@ import WorkWrap ( mkWrapper ) import Id ( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe ) import Module ( Module ) -import MkId ( mkCCallOpId ) +import MkId ( mkFCallId ) import IdInfo import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys ) import Type ( mkTyVarTys, splitAlgTyConApp_maybe ) @@ -212,10 +212,10 @@ tcCoreExpr (UfLitLit lit ty) = tcIfaceType ty `thenTc` \ ty' -> returnTc (Lit (MachLitLit lit ty')) -tcCoreExpr (UfCCall cc ty) +tcCoreExpr (UfFCall cc ty) = tcIfaceType ty `thenTc` \ ty' -> tcGetUnique `thenNF_Tc` \ u -> - returnTc (Var (mkCCallOpId u cc ty')) + returnTc (Var (mkFCallId u cc ty')) tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args) = mapTc tcCoreExpr args `thenTc` \ args' -> diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index ad60526..59d04eb 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -52,7 +52,7 @@ import FunDeps ( checkInstFDs ) import Generics ( validGenericInstanceType ) import Module ( Module, foldModuleEnv ) import Name ( getSrcLoc ) -import NameSet ( emptyNameSet, unitNameSet, nameSetToList ) +import NameSet ( unitNameSet, nameSetToList ) import PrelInfo ( eRROR_ID ) import PprType ( pprClassPred, pprPred ) import TyCon ( TyCon, isSynTyCon ) @@ -65,6 +65,7 @@ import Type ( splitDFunTy, isTyVarTy, import Subst ( mkTopTyVarSubst, substTheta ) import VarSet ( varSetElems ) import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy ) +import ForeignCall ( Safety(..) ) import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) import Name ( Name ) import SrcLoc ( SrcLoc ) @@ -814,7 +815,7 @@ checkInstHead dflags theta clas inst_taus maybe_tycon_app = splitTyConApp_maybe first_inst_tau Just (tycon, arg_tys) = maybe_tycon_app - ccallable_type dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty + ccallable_type dflags ty = isFFIArgumentTy dflags PlayRisky ty creturnable_type ty = isFFIImportResultTy dflags ty check_tyvars dflags clas inst_taus diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index a972fb7..222b2a0 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -24,7 +24,7 @@ import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat ) import TcMonad import TcMonoType ( kcHsSigTypes, tcScopedTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt ) import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList ) -import TcEnv ( TcId, tcLookupLocalIds, tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars, +import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv, tcExtendGlobalTyVars, tcInLocalScope ) import TcPat ( tcPat, tcMonoPatBndr, polyPatSig ) import TcType ( TcType, newTyVarTy ) @@ -32,7 +32,7 @@ import TcBinds ( tcBindsAndThen ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) import TcUnify ( unifyFunTy, unifyTauTy ) import Name ( Name ) -import TysWiredIn ( boolTy, mkListTy ) +import TysWiredIn ( boolTy ) import Id ( idType ) import BasicTypes ( RecFlag(..) ) import Type ( tyVarsOfType, isTauTy, mkFunTy, diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 1e37d8c..c7e77a9 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -15,7 +15,7 @@ import HscTypes ( PackageRuleBase ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) -import TcType ( zonkTcTyVarToTyVar, newTyVarTy ) +import TcType ( newTyVarTy ) import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) import TcMonoType ( kcHsSigTypes, tcHsSigType, tcScopedTyVars, checkSigTyVars ) import TcExpr ( tcExpr ) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index a0a00b0..afbd15e 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -10,7 +10,7 @@ module TcTyDecls ( #include "HsVersions.h" -import HsSyn ( TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..), +import HsSyn ( TyClDecl(..), ConDecl(..), ConDetails(..), getBangType, getBangStrictness, conDetailsTys ) import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) -- 1.7.10.4