import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys )
import Literal ( Literal(..) )
import PrelNames -- Lots of keys
-import PrimOp ( PrimOp(..), CCallTarget(..),CCall(..) )
+import PrimOp ( PrimOp(..) )
+import ForeignCall ( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget(..), DNCallSpec(..) )
import TysWiredIn ( mkTupleTy, tupleCon )
import PrimRep ( PrimRep(..) )
import Name ( nameModule, nameOccName, isGlobalName, isLocalName, NamedThing(getName) )
import UniqFM
import BasicTypes ( Boxity(..) )
import CStrings ( CLabelString, pprCLabelString )
-import CallConv ( CallConv )
import Outputable
import Char ( ord )
import List ( partition, elem, insertBy,any )
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
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)
-- filter to get only dataTyCons?
ilxTyConDef importing env tycon =
vcat [empty $$ line,
- text ".classunion" <+> (if importing then text "extern" else empty) <+> text "thunk"
- <+> ((nameReference env (getName tycon)) <> (ppr tycon)) <+> tyvars_text <+> alts_text]
+ text ".classunion" <+> (if importing then text "import" else empty) <+> tycon_ref <+> tyvars_text <+> super_text <+> alts_text]
where
+ tycon_ref = nameReference env (getName tycon) <> (ppr tycon)
+ super_text = if importing then empty else text "extends thunk" <> angleBrackets (text "class" <+> tycon_ref)
tyvars = tyConTyVars tycon
(ilx_tvs, _) = categorizeTyVars tyvars
alts_env = extendIlxEnvWithFormalTyVars env ilx_tvs
= 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 fcall _) args _)
= concat (ilxMapPlaceArgs 0 ilxCCallArgLocals env args)
ilxExprLocals _ _ = []
= 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
= 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"
]
-- 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
-- ldloc x arg of type Int
-- .tail callfunc <Int32> (!0) --> !0
--
- vcat [pushId env fun,ilxFunAppArgs env 0 (idIlxRepType fun) args tail_call known_clo]
+ vcat [pushId env fun,ilxFunAppAfterPush env fun args tail_call]
+
+ilxFunAppAfterPush env fun args tail_call
+ = -- For example:
+ -- ldloc f function of type forall a. a->a
+ -- ldloc x arg of type Int
+ -- .tail callfunc <Int32> (!0) --> !0
+ --
+ vcat [ilxFunAppArgs env 0 (idIlxRepType fun) args tail_call known_clo]
where
+ known_clo :: KnownClosure
known_clo =
case lookupIlxBindEnv env fun of
- Just (_, StgRhsClosure _ _ _ Updatable _ _) -> Nothing
+ Just (_, StgRhsClosure _ _ _ Updatable _ _) -> Nothing
Just (place, StgRhsClosure _ _ fvs _ args _) -> Just (place,fun,args,fvs)
_ -> trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun))) Nothing
--- Push as many arguments as ILX allows us to in one go.
+type KnownClosure = Maybe ( IlxEnv -- Of the binding site of the function
+ , Id -- The function
+ , [Var] -- Binders
+ , [Var]) -- Free vars of the closure
+
+-- Push as many arguments as ILX allows us to in one go, and call the function
-- Recurse until we're done.
+-- The function is already on the stack
+ilxFunAppArgs :: IlxEnv
+ -> Int -- Number of args already pushed (zero is a special case;
+ -- otherwise used only for place generation)
+ -> Type -- Type of the function
+ -> [StgArg] -- The arguments
+ -> Bool -- True <=> tail call please
+ -> KnownClosure -- Information about the function we're calling
+ -> SDoc
+
ilxFunAppArgs env num_sofar funty args tail_call known_clo
= vcat [vcat (ilxMapPlaceArgs num_sofar pushArgWithVoids env now_args),
call_instr <+> (if num_sofar == 0 then text "() /* first step in every Haskell app. is to a thunk */ " else empty)
Just rep_ty ->
let res = deepIlxRepType (applyTys rep_ty tys) in
if not (length tys == tyConArity tc ) then
- pprTrace "deepIlxRepType" (text "length tys <> tyConArity tc, ty = " <+> pprType ty <+> text ", length tys = " <+> ppr (length tys) <+> text ", tyConArity = " <+> ppr (tyConArity tc)) res
+ --pprTrace "deepIlxRepType" (text "length tys <> tyConArity tc, ty = " <+> pprType ty <+> text ", length tys = " <+> ppr (length tys) <+> text ", tyConArity = " <+> ppr (tyConArity tc))
+ res
else res
- -- The assert should hold because deepIlxRepType should
- -- only be applied to *types* (of kind *)
Nothing ->
-- collapse UnboxedTupleTyCon down when it contains VoidRep types.
+ -- e.g. (# State#, Int#, Int# #) ===> (# Int#, Int# #)
if isUnboxedTupleTyCon tc then
let tys' = map deepIlxRepType (filter (not. isVoidIlxRepType) tys) in
case tys' of
rep_ty_args = map deepIlxRepType ty_args
(ty_args,tm_args) = if isAlgTyCon tycon then splitTyArgs (tyConTyVars tycon) args else splitTyArgs1 args
--- split some type arguments off, throwing away the higher kinded ones for the moment
--- base the higher-kinded checks off a corresponding list of formals
+-- Split some type arguments off, throwing away the higher kinded ones for the moment.
+-- Base the higher-kinded checks off a corresponding list of formals.
+splitTyArgs :: [Var] -- Formals
+ -> [StgArg] -- Actuals
+ -> ([Type], [StgArg])
splitTyArgs (htv:ttv) (StgTypeArg h:t)
| isIlxTyVar htv = ((h:l), r)
| otherwise = trace "splitTyArgs: threw away higher kinded type arg" (l, r)
where (l,r) = splitTyArgs ttv t
splitTyArgs _ l = ([],l)
--- split some type arguments off, where none should be higher kinded
-splitTyArgs1 (StgTypeArg h:t)
- = ((h:l), r)
- where (l,r) = splitTyArgs1 t
-splitTyArgs1 l = ([],l)
-
+-- Split some type arguments off, where none should be higher kinded
+splitTyArgs1 :: [StgArg] -> ([Type], [StgArg])
+splitTyArgs1 (StgTypeArg ty : args) = (ty:tys, args')
+ where
+ (tys, args') = splitTyArgs1 args
+splitTyArgs1 args = ([], args)
ilxConRef env data_con
= pprId data_con <> pprValArgTys ilxTypeL env' (map deepIlxRepType (filter (not . isVoidIlxRepType) arg_tys))
\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
-- These can all also accept unlifted parameter types so we explicitly lift.
(arrayPrimTyConKey, (\[ty] -> repArray (ilxTypeL2 ty))),
(mutableArrayPrimTyConKey, (\[_, ty] -> repMutArray (ilxTypeL2 ty))),
- (weakPrimTyConKey, (\[_, ty] -> repWeak (ilxTypeL2 ty))),
+ (weakPrimTyConKey, (\[ty] -> repWeak (ilxTypeL2 ty))),
(mVarPrimTyConKey, (\[_, ty] -> repMVar (ilxTypeL2 ty))),
(mutVarPrimTyConKey, (\[ty1, ty2] -> repMutVar (ilxTypeL2 ty1) (ilxTypeL2 ty2))),
(mutableByteArrayPrimTyConKey, (\_ -> repByteArray)),
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"))
%************************************************************************
\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)) 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"
+ | otherwise = ilxTypeR env (deepIlxRepType ret_ty)
+ (ty_args,tm_args) = splitTyArgs1 args
+
+ilxFCall env (DNCall (DNCallSpec call_instr)) args ret_ty
+ = ilxComment (text "IL call") <+>
+ vcat [vcat (ilxMapPlaceArgs 0 pushEvalArg env tm_args),
+ ptext call_instr
+ -- In due course we'll need to pass the type arguments
+ -- and to do that we'll need to have more than just a string
+ -- for call_instr
+ ]
+ where
(ty_args,tm_args) = splitTyArgs1 args
+-- Push and argument and force its evaluation if necessary.
+pushEvalArg _ (StgTypeArg _) = empty
+pushEvalArg env (StgVarArg arg) = ilxFunApp env arg [] False
+pushEvalArg env (StgLitArg lit) = pushLit env lit
+
hasTyCon (TyConApp tc _) tc2 = tc == tc2
hasTyCon _ _ = False
projects / ghc-hetmet.git / blobdiff