%
-\section{Generate COM+ extended assembler}
+\section{Generate .NET extended IL}
\begin{code}
module IlxGen( ilxGen ) where
import Char ( ord, chr )
import StgSyn
-import Id ( idType, idName, isDeadBinder, idArityInfo )
-import IdInfo ( arityLowerBound )
+import Id ( idType, idName, isDeadBinder, idArity )
import Var ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName )
import VarEnv
+import VarSet ( isEmptyVarSet )
import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons,
- newTyConRep, tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity
+ tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity
)
import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind,
- isUnLiftedType, isTyVarTy, mkTyVarTy, predRepTy,
- splitForAllTys, splitFunTys, applyTy, applyTys
+ isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep, pprType,
+ splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes
)
import TypeRep ( Type(..) )
-import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys )
+import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys, DataCon(..) )
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 Subst ( substTy, mkTyVarSubst )
+import Name ( nameModule, nameOccName, isExternalName, isInternalName, NamedThing(getName) )
+import Subst ( substTyWith )
import Module ( Module, PackageName, ModuleName, moduleName,
- modulePackage, preludePackage,
+ modulePackage, basePackage,
isHomeModule, isVanillaModule,
pprModuleName, mkHomeModule, mkModuleName
)
import UniqFM
import BasicTypes ( Boxity(..) )
import CStrings ( CLabelString, pprCLabelString )
-import CallConv ( CallConv )
import Outputable
import Char ( ord )
import List ( partition, elem, insertBy,any )
import UniqSet
-import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
-import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
+import TysPrim ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
-- opt_SimplDoEtaReduction is used to help with assembly naming conventions for different
-- versions of compiled Haskell code. We add a ".O" to all assembly and module
-- names when this is set (because that's clue that -O was set).
-- One day this will be configured by the command line.
-import CmdLineOpts ( opt_InPackage, opt_SimplDoEtaReduction )
+import DynFlags ( opt_InPackage, opt_SimplDoEtaReduction )
+
+import Util ( lengthIs, equalLength )
\end{code}
ilxGen :: Module -> [TyCon] -> [(StgBinding,[Id])] -> SDoc
-- The TyCons should include those arising from classes
ilxGen mod tycons binds_w_srts
- = vcat [vcat (map (ilxImportPackage topenv) (uniqSetToList import_packages)),
+ = vcat [ text ".module '" <> (ppr (moduleName mod)) <> hscOptionQual <> text "o'",
+ text ".assembly extern 'mscorlib' {}",
+ vcat (map (ilxImportPackage topenv) (uniqSetToList import_packages)),
vcat (map (ilxImportModule topenv) (uniqSetToList import_modules)),
vcat (map (ilxImportTyCon topenv) (uniqSetToList import_tycons)),
vcat (map (ilxImportCCall topenv) (map snd (ufmToList import_ccalls))),
\begin{code}
-importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo-> ImportsInfo
+importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo -> ImportsInfo
importsBinds env binds = foldR (importsBind env) binds
importsNone :: 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
importsVar env v = importsName env (idName v). importsType env (idType v)
importsName env n
- | isLocalName n = importsNone
- | ilxEnvModule env == nameModule n = importsNone
+ | isInternalName n = importsNone
+ | ilxEnvModule env == nameModule n = importsNone
| isHomeModule (nameModule n) = addModuleImpInfo (moduleName (nameModule n))
-- See HACK below
| isVanillaModule (nameModule n) && not inPrelude = importsPrelude
| otherwise = addPackageImpInfo (modulePackage (nameModule n))
+importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC")
+ | otherwise = addPackageImpInfo basePackage
+
+
importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
importsType env ty = importsType2 env (deepIlxRepType ty)
importsType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
-importsType2 env (AppTy f x) = importsType2 env f . importsType2 env x
+importsType2 env (AppTy f x) = importsType2 env f . importsType2 env x
importsType2 env (TyVarTy _) = importsNone
importsType2 env (TyConApp tc args) =importsTyCon env tc . importsTypeArgs2 env args
importsType2 env (FunTy arg res) = importsType env arg . importsType2 env res
importsDataCon env dcon = importsTyCon env (dataConTyCon dcon)
importsTyCon env tc | (not (isDataTyCon tc) ||
- isLocalName (getName tc) ||
+ isInternalName (getName tc) ||
ilxEnvModule env == nameModule (getName tc)) = importsNone
-importsTyCon env tc | otherwise = importsName env (getName tc) . addTyConImpInfo tc
+importsTyCon env tc | otherwise = importsName env (getName tc) . addTyConImpInfo tc .
+ foldR (importsTyConDataCon env) (tyConDataCons tc)
-importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC")
- | otherwise = addPackageImpInfo preludePackage
-type StaticCCallInfo = (CLabelString,CallConv,[Type],Type)
+importsTyConDataCon :: IlxEnv -> DataCon -> ImportsInfo -> ImportsInfo
+importsTyConDataCon env dcon = foldR (importsTyConDataConType env) (filter (not . isVoidIlxRepType) (dataConRepArgTys dcon))
+
+importsTyConDataConType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
+importsTyConDataConType env ty = importsTyConDataConType2 env (deepIlxRepType ty)
+
+importsTyConDataConType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
+importsTyConDataConType2 env (AppTy f x) = importsTyConDataConType2 env f . importsTyConDataConType2 env x
+importsTyConDataConType2 env (TyVarTy _) = importsNone
+importsTyConDataConType2 env (TyConApp tc args) = importsTyConDataConTypeTyCon env tc . importsTyConDataConTypeArgs2 env args
+importsTyConDataConType2 env (FunTy arg res) = importsTyConDataConType env arg . importsTyConDataConType2 env res
+importsTyConDataConType2 env (ForAllTy tv body_ty) = importsTyConDataConType2 env body_ty
+importsTyConDataConType2 env (NoteTy _ ty) = importsTyConDataConType2 env ty
+importsTyConDataConType2 _ _ = panic "IlxGen.lhs: importsTyConDataConType2 ty"
+importsTyConDataConTypeArgs2 env tys = foldR (importsTyConDataConType2 env) tys
+
+importsTyConDataConTypeTyCon env tc | (not (isDataTyCon tc) ||
+ isInternalName (getName tc) ||
+ ilxEnvModule env == nameModule (getName tc)) = importsNone
+importsTyConDataConTypeTyCon env tc | otherwise = importsName env (getName tc)
+
+
+type StaticCCallInfo = (CLabelString,CCallConv,[Type],Type)
type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon, UniqFM StaticCCallInfo)
-- (Packages, Modules, Datatypes, Imported CCalls)
ilxImportTyCon _ _ | otherwise = empty
ilxImportPackage :: IlxEnv -> PackageName -> SDoc
-ilxImportPackage _ p = text ".assembly extern ilx" <+> singleQuotes (ppr p <> hscOptionQual) <+> text "{ }"
+ilxImportPackage _ p = text ".assembly extern" <+> singleQuotes (ppr p <> hscOptionQual) <+> text "{ }"
ilxImportModule :: IlxEnv -> ModuleName -> SDoc
-ilxImportModule _ m = text ".module extern ilx" <+> singleQuotes (ppr m <> hscOptionQual <> text ".dll")
+ilxImportModule _ m = text ".module extern" <+> singleQuotes (ppr m <> hscOptionQual <> text "o")
-- Emit a P/Invoke declaration for the imported C function
-- TODO: emit the right DLL name
ilxImportCCall :: IlxEnv -> StaticCCallInfo -> SDoc
ilxImportCCall env (c,cc,args,ret) =
- text ".method static private pinvokeimpl" <+>
+ text ".method static assembly pinvokeimpl" <+>
parens (doubleQuotes (text "HSstd_cbits.dll") <+> text "cdecl") <+> retdoc <+> singleQuotes (pprCLabelString c) <+>
pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) args)) <+>
- text "native managed { }"
+ text "unmanaged preservesig { }"
where
retdoc =
if isVoidIlxRepType ret then text "void"
-- 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
ilxWipeOne env id
= case lookupIlxVarEnv env id of
- Just Local -> text "ldloca " <+> pprId id <+> text "initobj" <+> (ilxTypeL env (idIlxRepType id))
+ Just Local -> text "ldloca " <+> pprId id <+> text "initobj.any" <+> (ilxTypeL env (idIlxRepType id))
Just Arg -> text "deadarg " <+> pprId id <+> text "," <+> (ilxTypeL env (idIlxRepType id))
Just (CloVar _) -> ilxComment (text "not yet wiping closure variable" <+> pprId id )
_ -> ilxComment (text "cannot wipe non-local/non-argument" <+> pprId id )
-- 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
+ _ -> Nothing -- trace (show fun ++ " --> " ++ show (idArity fun))
+
+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.
+-- 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)
get_type_args max ((arg@(StgTypeArg v)):rest) env (ForAllTy tv rem_funty)
= if isIlxTyVar tv then
let env2 = extendIlxEnvWithFormalTyVars env [tv] in
- let rest_ty = deepIlxRepType (substTy (mkTyVarSubst [tv] [v]) rem_funty) in
+ let rest_ty = deepIlxRepType (substTyWith [tv] [v] rem_funty) in
let (now,now_tys,env3,later,later_ty) = get_type_args (max - 1) rest env rest_ty in
let arg_ty = mkTyVarTy tv in
(arg:now,(arg,arg_ty):now_tys,env2, later, later_ty)
= ([],[],env,args,funty)
get_term_args n max args env funty
| (case known_clo of
- Just (_,_,needed,_) -> (length needed == n)
+ Just (_,_,needed,_) -> needed `lengthIs` n
Nothing -> False)
-- Stop if we have the optimal number for a direct call
= ([],[],env,args,funty)
-- the "callfunc" case.
basic_call_instr =
case known_clo of
- Just (known_env,fun,needed,fvs) | (length needed == length now_args) &&
+ Just (known_env,fun,needed,fvs) | (equalLength needed now_args) &&
all (\x -> elemIlxTyEnv x env) free_ilx_tvs ->
vcat [text "callclo class",
nameReference env (idName fun) <+> singleQuotes (ilxEnvQualifyByModule env (ppr fun)),
where
pushFv id = if elem id rec then text "ldnull" else pushId env id
(free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
- clotext = pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)
+ clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)
ilxFixupRec env rec (bndr, _) | isVoidIlxRepId bndr = ilxComment (text "no recursive fixup for void-rep-id")
text "stclofld" <+> clotext <> text "," <+> pprId recid]
else text "//no fixup needed for" <+> pprId recid
(free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
- clotext = pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)
+ clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)
ilxTopRhs mod env (bndr, StgRhsClosure _ _ fvs upd args rhs)
= vcat [vcat (map (pushId env) free_vs),
(if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non verifiable...."))),
- text "newclo" <+> pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs),
+ text "newclo" <+> pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs),
text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr)
]
where
pushLit env (MachWord64 w) = text "ldc.i8" <+> integer w <+> text "conv.u8"
pushLit env (MachFloat f) = text "ldc.r4" <+> rational f
pushLit env (MachDouble f) = text "ldc.r8" <+> rational f
-pushLit env (MachLitLit _ _) = trace "WARNING: Cannot compile MachLitLit to ILX in IlxGen.lhs" (text "// MachLitLit!!! Not valid in ILX!!")
-pushLit env (MachAddr w) = text "ldc.i4" <+> integer w <+> text "conv.i"
-
+pushLit env (MachNullAddr) = text "ldc.i4 0"
+pushLit env (MachLabel l _) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!! Not valid in ILX!!")
pprIlxTopVar env v
- | isGlobalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> singleQuotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n))
+ | isExternalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> singleQuotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n))
| otherwise = pprId (nameOccName n)
where
n = idName v
isVoidIlxRepType (NoteTy _ ty) = isVoidIlxRepType ty
isVoidIlxRepType (TyConApp tc _) | (tyConPrimRep tc == VoidRep) = True
isVoidIlxRepType (TyConApp tc tys)
- = case newTyConRep tc of
- Just rep_ty -> isVoidIlxRepType (applyTys rep_ty tys)
- Nothing ->
- isUnboxedTupleTyCon tc &&
- null (filter (not. isVoidIlxRepType) tys)
+ = isUnboxedTupleTyCon tc && null (filter (not. isVoidIlxRepType) tys)
isVoidIlxRepType _ = False
isVoidIlxRepId id = isVoidIlxRepType (idType id)
= FunTy (deepIlxRepType l) (deepIlxRepType r)
deepIlxRepType ty@(TyConApp tc tys)
- = case newTyConRep tc of
- 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
- 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.
+ = -- 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
_ -> mkTupleTy Unboxed (length tys') tys'
else
TyConApp tc (map deepIlxRepType tys)
-deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x)
+deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x)
deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty)
deepIlxRepType (NoteTy _ ty) = deepIlxRepType ty
-deepIlxRepType (PredTy p) = deepIlxRepType (predRepTy p)
+deepIlxRepType (PredTy p) = deepIlxRepType (predTypeRep p)
deepIlxRepType ty@(TyVarTy tv) = ty
idIlxRepType id = deepIlxRepType (idType id)
ilxTypeL env ty | isUnLiftedType ty || isVoidIlxRepType ty = ilxTypeR env ty
ilxTypeL env ty = text "thunk" <> angleBrackets (ilxTypeR env ty)
+
--------------------------
-- Print non-thunkable version of type.
--
ilxTypeR :: IlxEnv -> Type -> SDoc
ilxTypeR env ty | isVoidIlxRepType ty = text "/* unit skipped */"
ilxTypeR env ty@(AppTy f _) | isTyVarTy f = ilxComment (text "type app:" <+> pprType ty) <+> (text "class [mscorlib]System.Object")
-ilxTypeR env ty@(AppTy f x) = trace "ilxTypeR: should I be beta reducing types?!" (ilxComment (text "ilxTypeR: should I be beta reducing types...") <+> ilxTypeR env (applyTy f x))
+ilxTypeR env ty@(AppTy f x) = trace "ilxTypeR: should I be beta reducing types?!" (ilxComment (text "ilxTypeR: should I be beta reducing types?!") <+> ilxTypeR env (applyTy f x))
ilxTypeR env (TyVarTy tv) = ilxTyVar env tv
-- The following is a special rule for types constructed out of
pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran])
-ilxTyConApp env tc args =
- case lookupUFM tyPrimConTable (getUnique tc) of
+ilxTyConApp env tcon args =
+ case lookupUFM tyPrimConTable (getUnique tcon) of
Just f -> f args env
Nothing ->
- (if isUnboxedTupleTyCon tc then pprIlxUnBoxedTyConApp else pprIlxBoxedTyConApp)
- env ((nameReference env (getName tc)) <> (ppr tc)) args
+ (if isUnboxedTupleTyCon tcon then pprIlxUnboxedTupleTyConApp else pprIlxBoxedTyConApp)
+ env tcon args
-pprIlxUnBoxedTyConApp env tcdoc args = text "value class" <+> tcdoc <> pprTypeArgs ilxTypeL env args
-pprIlxBoxedTyConApp env tcdoc args = text "class" <+> tcdoc <> pprTypeArgs ilxTypeR env args
+pprIlxTyCon env tcon = nameReference env (getName tcon) <> ppr tcon
+pprIlxUnboxedTupleTyConApp env tcon args
+ = text "/* unboxed */ value class" <+> pprIlxTyCon env tcon' <> pprTypeArgs ilxTypeL env non_void
+ where
+ non_void = filter (not . isVoidIlxRepType) args
+ tcon' = dataConTyCon (tupleCon Unboxed (length non_void))
+pprIlxBoxedTyConApp env tcon args
+ = pprIlxNamedTyConApp env (pprIlxTyCon env tcon) args
+pprIlxNamedTyConApp env tcon_text args
+ = text "class" <+> tcon_text <> pprTypeArgs ilxTypeR env args
-- Returns e.g: <Int32, Bool>
+-- Void-sized type arguments are _always_ eliminated, everywhere.
+-- If the type constructor is an unboxed tuple type then it should already have
+-- been adjusted to be the correct constructor.
pprTypeArgs f env tys = pprTypeArgs_aux f env (filter (not . isVoidIlxRepType) tys)
pprTypeArgs_aux f env [] = empty
-- Only a subset of Haskell types can be generalized using the type quantification
-- of ILX
isIlxForAllKind h =
- ( h == liftedTypeKind) ||
- ( h == unliftedTypeKind) ||
- ( h == openTypeKind)
+ ( h `eqKind` liftedTypeKind) ||
+ ( h `eqKind` unliftedTypeKind) ||
+ ( h `eqKind` openTypeKind)
isIlxTyVar v = isTyVar v && isIlxForAllKind (tyVarKind v)
line = text "// ----------------------------------"
-hscOptionQual = if opt_SimplDoEtaReduction then text ".ilx-O" else text ".ilx-Onot"
+hscOptionQual = text ".i_"
nameReference env n
- | isLocalName n = empty
+ | isInternalName n = empty
| ilxEnvModule env == nameModule n = text ""
| isHomeModule (nameModule n) = moduleNameReference (moduleName (nameModule n))
-- HACK: no Vanilla modules should be around, but they are!! This
-- gets things working for the scenario "standard library linked as one
-- assembly with multiple modules + a one module program running on top of this"
-- Same applies to all other mentions of Vailla modules in this file
- | isVanillaModule (nameModule n) && not inPrelude = preludePackageReference
+ | isVanillaModule (nameModule n) && not inPrelude = basePackageReference
| isVanillaModule (nameModule n) && inPrelude = moduleNameReference (moduleName (nameModule n))
-- end hack
| otherwise = packageReference (modulePackage (nameModule n))
-packageReference p = brackets ((text "ilx") <+> singleQuotes (ppr p <> hscOptionQual))
-moduleNameReference m = brackets ((text ".module") <+> (text "ilx") <+> singleQuotes (pprModuleName m <> hscOptionQual <> text ".dll"))
+packageReference p = brackets (singleQuotes (ppr p <> hscOptionQual))
+moduleNameReference m = brackets ((text ".module") <+> (singleQuotes (pprModuleName m <> hscOptionQual <> text "o")))
moduleReference env m
| ilxEnvModule env == m = text ""
| isHomeModule m = moduleNameReference (moduleName m)
--- See hack above
- | isVanillaModule m && not inPrelude = preludePackageReference
+ -- See hack above
+ | isVanillaModule m && not inPrelude = basePackageReference
| isVanillaModule m && inPrelude = moduleNameReference (moduleName m)
--- end hack
+ -- end hack
| otherwise = packageReference (modulePackage m)
-preludePackageReference = packageReference preludePackage
-inPrelude = preludePackage == opt_InPackage
+basePackageReference = packageReference basePackage
+inPrelude = basePackage == opt_InPackage
------------------------------------------------
-- This code is copied from absCSyn/CString.lhs,
-- still a mess though. Also, still have to do the
-- right thing for embedded nulls.
-pprFSInILStyle :: FAST_STRING -> SDoc
-pprFSInILStyle fs = doubleQuotes (text (stringToC (_UNPK_ fs)))
+pprFSInILStyle :: FastString -> SDoc
+pprFSInILStyle fs = doubleQuotes (text (stringToC (unpackFS fs)))
stringToC :: String -> String
-- Convert a string to the form required by C in a C literal string
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))
+ | isUnboxedTupleCon data_con
+ = let data_con' = tupleCon Unboxed (length non_void_args)in
+ pprId data_con' <> arg_text
+ | otherwise
+ = pprId data_con <> arg_text
where
+ arg_text = pprValArgTys ilxTypeL env' (map deepIlxRepType non_void_args)
+ non_void_args = filter (not . isVoidIlxRepType) arg_tys
(tyvars, tau_ty) = splitForAllTys (dataConRepType data_con)
(arg_tys, _) = splitFunTys tau_ty
env' = formalIlxEnv env tyvars
\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
type IlxTyFrag = IlxEnv -> SDoc
ilxType s env = text s
+ilxLift ty env = text "thunk" <> angleBrackets (ty env)
+
ilxTypeSeq :: [IlxTyFrag] -> IlxTyFrag
ilxTypeSeq ops env = hsep (map (\x -> x env) ops)
(word64PrimTyConKey, (\_ -> repWord64)),
(floatPrimTyConKey, (\_ -> repFloat)),
(doublePrimTyConKey, (\_ -> repDouble)),
+ -- 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))),
(mVarPrimTyConKey, (\[_, ty] -> repMVar (ilxTypeL2 ty))),
(mutVarPrimTyConKey, (\[ty1, ty2] -> repMutVar (ilxTypeL2 ty1) (ilxTypeL2 ty2))),
(mutableByteArrayPrimTyConKey, (\_ -> repByteArray)),
ilxTypeR2 :: Type -> IlxTyFrag
ilxTypeR2 ty env = ilxTypeR env ty
-ilxMethA = ilxType "!!0"
-ilxMethB = ilxType "!!1"
+ilxMethTyVarA = ilxType "!!0"
+ilxMethTyVarB = ilxType "!!1"
prelGHCReference :: IlxTyFrag
prelGHCReference env =
if ilxEnvModule env == mkHomeModule (mkModuleName "PrelGHC") then empty
else if inPrelude then moduleNameReference (mkModuleName "PrelGHC")
- else preludePackageReference
+ else basePackageReference
prelBaseReference :: IlxTyFrag
prelBaseReference env =
if ilxEnvModule env == mkHomeModule (mkModuleName "PrelBase") then empty
else if inPrelude then moduleNameReference (mkModuleName "PrelBase")
- else preludePackageReference
+ else basePackageReference
repThread = ilxType "class [mscorlib]System.Threading.Thread /* ThreadId# */ "
repByteArray = ilxType "unsigned int8[] /* ByteArr# */ "
ilxTyPair l r = ilxTyParams [l,r]
ilxTyTriple l m r = ilxTyParams [l,m,r]
ilxTyQuad l m1 m2 r = ilxTyParams [l,m1,m2,r]
-ilxUnboxedPairRep l r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z1H",ilxTyPair l r]
-ilxUnboxedTripleRep l m r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z2H",ilxTyTriple l m r]
-ilxUnboxedQuadRep l m1 m2 r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z3H",ilxTyQuad l m1 m2 r]
+ilxUnboxedEmptyRep = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z1H"]
+ilxUnboxedPairRep l r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z2H",ilxTyPair l r]
+ilxUnboxedTripleRep l m r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z3H",ilxTyTriple l m r]
+ilxUnboxedQuadRep l m1 m2 r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z4H",ilxTyQuad l m1 m2 r]
+
+ilxTyIO b = ilxTypeSeq [ilxType "(func ( /* unit skipped */ ) --> ", b, ilxType ")"]
ilxTyParams :: [IlxTyFrag] -> IlxTyFrag
ilxTyParams [] env = empty
ilxCltUn = ilxOpSeq [ilxOp "clt.un ",ilxMkBool]
ilxCleUn = ilxOpSeq [ilxOp "cgt.un ldc.i4 0 ceq ",ilxMkBool]
-ilxForeignToAddrOp = ilxOpSeq [ilxOp "ldfld void *" , repForeign, ilxOp "::contents"]
+ilxAddrOfForeignOp = ilxOpSeq [ilxOp "ldfld void *" , repForeign, ilxOp "::contents"]
+ilxAddrOfByteArrOp = ilxOp "ldc.i4 0 ldelema unsigned int8"
ilxPrimOpTable :: PrimOp -> [StgArg] -> IlxOpFrag
ilxPrimOpTable op
IntLtOp -> simp_op ilxClt
IntLeOp -> simp_op ilxCle
- IntToInt8Op -> simp_op (ilxOp"conv.i1")
- IntToInt16Op -> simp_op (ilxOp "conv.i2")
- IntToInt32Op -> simp_op (ilxOp "conv.i4")
- WordToWord8Op -> simp_op (ilxOp "conv.u1")
- WordToWord16Op -> simp_op (ilxOp "conv.u2")
- WordToWord32Op -> simp_op (ilxOp "conv.u4")
+ Narrow8IntOp -> simp_op (ilxOp"conv.i1")
+ Narrow16IntOp -> simp_op (ilxOp "conv.i2")
+ Narrow32IntOp -> simp_op (ilxOp "conv.i4")
+ Narrow8WordOp -> simp_op (ilxOp "conv.u1")
+ Narrow16WordOp -> simp_op (ilxOp "conv.u2")
+ Narrow32WordOp -> simp_op (ilxOp "conv.u4")
WordGtOp -> simp_op ilxCgtUn
WordGeOp -> simp_op ilxCgeUn
IntNegOp -> simp_op (ilxOp "neg")
IntRemOp -> simp_op (ilxOp "rem")
+ -- Addr# ops:
+ AddrAddOp -> simp_op (ilxOp "add")
+ AddrSubOp -> simp_op (ilxOp "sub")
+ AddrRemOp -> simp_op (ilxOp "rem")
+ Int2AddrOp -> warn_op "int2Addr" (simp_op (ilxOp "/* PrimOp int2Addr */ "))
+ Addr2IntOp -> warn_op "addr2Int" (simp_op (ilxOp "/* PrimOp addr2Int */ "))
+
-- Word#-related ops:
WordAddOp -> simp_op (ilxOp "add")
WordSubOp -> simp_op (ilxOp "sub")
WordQuotOp -> simp_op (ilxOp "div")
WordRemOp -> simp_op (ilxOp "rem")
- Addr2IntOp -> simp_op (ilxOp "conv.i4") -- Addresses are very dodgy for ILX. They are used for both C-strings and
- Int2AddrOp -> simp_op (ilxOp "conv.i") -- the FFI. This needs more work.
ISllOp -> simp_op (ilxOp "shl")
ISraOp -> simp_op (ilxOp "shr")
ISrlOp -> simp_op (ilxOp "shr.un")
IntAddCOp -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntAddCOp" [] [repInt, repInt])
IntSubCOp -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntSubCOp" [] [repInt, repInt])
- IntMulCOp -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntMulCOp" [] [repInt, repInt])
IntGcdOp -> simp_op (ilxCallSuppMeth repInt "IntGcdOp" [] [repInt, repInt])
FloatSinhOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sinh(float64) conv.r4")
FloatCoshOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Cosh(float64) conv.r4")
FloatTanhOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Tanh(float64) conv.r4")
- FloatPowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4") -- ** op, make use of implicit cast to r8...
+ FloatPowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4") -- ** op, make use of implicit cast to r8...
DoubleExpOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Exp(float64)")
DoubleLogOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Log(float64)")
Integer2WordOp -> simp_op (ilxCallSuppMeth repWord "Integer2WordOp" [] [repInt, repByteArray])
Int2IntegerOp -> simp_op (ilxCallSuppMeth repInteger "Int2IntegerOp" [] [repInt])
Word2IntegerOp -> simp_op (ilxCallSuppMeth repInteger "Word2IntegerOp" [] [repWord])
- IntegerToInt64Op -> simp_op (ilxCallSuppMeth repInt64 "IntegerToInt64Op" [] [repInt,repByteArray])
+-- IntegerToInt64Op -> simp_op (ilxCallSuppMeth repInt64 "IntegerToInt64Op" [] [repInt,repByteArray])
Int64ToIntegerOp -> simp_op (ilxCallSuppMeth repInteger "Int64ToIntegerOp" [] [repInt64])
- IntegerToWord64Op -> simp_op (ilxCallSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray])
+-- IntegerToWord64Op -> simp_op (ilxCallSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray])
Word64ToIntegerOp -> simp_op (ilxCallSuppMeth repInteger "Word64ToIntegerOp" [] [repWord64])
-- ForeignObj: load the address inside the object first
-- TODO: is this remotely right?
- IndexOffForeignObjOp_Char -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"])
- IndexOffForeignObjOp_WideChar -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof int32 mul add ldind.u4"])
- IndexOffForeignObjOp_Int -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof int32 mul add ldind.i4"])
- IndexOffForeignObjOp_Word -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"])
- IndexOffForeignObjOp_Addr -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof native unsigned int mul add ldind.i "])
- IndexOffForeignObjOp_StablePtr -> ty1_arg2_op (\ty fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof native unsigned int mul add ldind.ref "])
- IndexOffForeignObjOp_Float -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof float32 mul add ldind.r4"])
- IndexOffForeignObjOp_Double -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof float64 mul add ldind.r8"])
- IndexOffForeignObjOp_Int8 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof int8 mul add ldind.i1"])
- IndexOffForeignObjOp_Int16 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof int16 mul add ldind.i2"])
- IndexOffForeignObjOp_Int32 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof int32 mul add ldind.i4"])
- IndexOffForeignObjOp_Int64 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof int64 mul add ldind.i8"])
- IndexOffForeignObjOp_Word8 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"])
- IndexOffForeignObjOp_Word16 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof unsigned int16 mul add ldind.u2"])
- IndexOffForeignObjOp_Word32 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"])
- IndexOffForeignObjOp_Word64 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxForeignToAddrOp, n, ilxOp "sizeof unsigned int64 mul add ldind.u8"])
+ EqForeignObj -> warn_op "eqForeignObj" (simp_op (ilxOp "pop /* PrimOp eqForeignObj */ "))
+ IndexOffForeignObjOp_Char -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"])
+ IndexOffForeignObjOp_WideChar -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.u4"])
+ IndexOffForeignObjOp_Int -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.i4"])
+ IndexOffForeignObjOp_Word -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"])
+ IndexOffForeignObjOp_Addr -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof native unsigned int mul add ldind.i "])
+ IndexOffForeignObjOp_StablePtr -> ty1_arg2_op (\ty fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof native unsigned int mul add ldind.ref "])
+ IndexOffForeignObjOp_Float -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof float32 mul add ldind.r4"])
+ IndexOffForeignObjOp_Double -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof float64 mul add ldind.r8"])
+ IndexOffForeignObjOp_Int8 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int8 mul add ldind.i1"])
+ IndexOffForeignObjOp_Int16 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int16 mul add ldind.i2"])
+ IndexOffForeignObjOp_Int32 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.i4"])
+ IndexOffForeignObjOp_Int64 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int64 mul add ldind.i8"])
+ IndexOffForeignObjOp_Word8 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"])
+ IndexOffForeignObjOp_Word16 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int16 mul add ldind.u2"])
+ IndexOffForeignObjOp_Word32 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"])
+ IndexOffForeignObjOp_Word64 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int64 mul add ldind.u8"])
ReadOffAddrOp_Char -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1")
ReadOffAddrOp_WideChar -> simp_op (ilxOp "sizeof int32 mul add ldind.u4")
{- Addr# -> Int# -> Char# -> State# s -> State# s -}
{- should be monadic??? -}
+ NewPinnedByteArrayOp_Char -> warn_op "newPinnedByteArray" (simp_op (ilxOp "newarr [mscorlib]System.Byte "))
NewByteArrayOp_Char -> simp_op (ilxOp "newarr [mscorlib]System.Byte")
-- NewByteArrayOp_Int -> simp_op (ilxOp "newarr [mscorlib]System.Int32")
-- NewByteArrayOp_Word -> simp_op (ilxOp "newarr [mscorlib]System.UInt32")
-- NewByteArrayOp_Int64 -> simp_op (ilxOp "newarr [mscorlib]System.Int64") TODO: there is no unique for this one -}
-- NewByteArrayOp_Word64 -> simp_op (ilxOp "newarr [mscorlib]System.UInt64") -}
{- Int# -> State# s -> (# State# s, MutByteArr# s #) -}
+ ByteArrayContents_Char -> warn_op "byteArrayContents" (simp_op ilxAddrOfByteArrOp)
UnsafeFreezeByteArrayOp -> ty1_op (\ty1 -> ilxOp "nop ")
{- MutByteArr# s -> State# s -> (# State# s, ByteArr# #) -}
WriteMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "stfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"])
{- MutVar# s a -> a -> State# s -> State# s -}
- NewArrayOp -> ty2_op (\ty1 ty2 -> ilxCallSuppMeth (ilxType "!!0[]") "newArray" [ty1] [repInt,ilxMethA])
+ NewArrayOp -> ty2_op (\ty1 ty2 -> ilxCallSuppMeth (ilxType "!!0[]") "newArray" [ty1] [repInt,ilxMethTyVarA])
{- Int# -> a -> State# s -> (# State# s, MutArr# s a #) -}
IndexArrayOp -> ty1_op (\ty1 -> ilxOp "ldelem.ref")
{- Array# a -> Int# -> (# a #) -}
RaiseOp -> ty2_op (\ty1 ty2 -> ilxOp "throw")
CatchOp -> ty2_op (\ty1 ty2 ->
- ilxCallSuppMeth ilxMethA "'catch'" [ty1,ty2] [ilxOp "(func ( /* unit skipped */ ) --> !!0)", ilxOp "(func (!!1) --> (func ( /* unit skipped */ ) --> !!0))"])
+ ilxCallSuppMeth ilxMethTyVarA "'catch'" [ty1,ty2] [ilxLift (ilxTyIO (ilxType "!!0")),
+ ilxOp "thunk<(func (!!1) --> (func ( /* unit skipped */ ) --> !!0))>"])
{- (State# RealWorld -> (# State# RealWorld, a #) )
-> (b -> State# RealWorld -> (# State# RealWorld, a #) )
-> State# RealWorld
-}
BlockAsyncExceptionsOp -> ty1_op (\ty1 ->
- ilxCallSuppMeth ilxMethA "blockAsyncExceptions" [ty1] [ilxOp "(func ( /* unit skipped */ ) --> !!0)"])
+ ilxCallSuppMeth ilxMethTyVarA "blockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))])
{- (State# RealWorld -> (# State# RealWorld, a #))
-> (State# RealWorld -> (# State# RealWorld, a #))
-}
UnblockAsyncExceptionsOp -> ty1_op (\ty1 ->
- ilxCallSuppMeth ilxMethA "unblockAsyncExceptions" [ty1] [ilxOp "(func ( /* unit skipped */ ) --> !!0)"])
+ ilxCallSuppMeth ilxMethTyVarA "unblockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))])
{-
State# RealWorld -> (# State# RealWorld, a #))
{- State# s -> (# State# s, MVar# s a #) -}
TakeMVarOp -> ty2_op (\sty ty ->
- ilxCallSuppMeth ilxMethA "takeMVar" [ty] [repMVar ilxMethA])
+ ilxCallSuppMeth ilxMethTyVarA "takeMVar" [ty] [repMVar ilxMethTyVarA])
{- MVar# s a -> State# s -> (# State# s, a #) -}
-- These aren't yet right
TryTakeMVarOp -> ty2_op (\sty ty ->
- ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethA) "tryTakeMVar" [ty] [repMVar ilxMethA])
+ ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA])
{- MVar# s a -> State# s -> (# State# s, a #) -}
TryPutMVarOp -> ty2_op (\sty ty ->
- ilxCallSuppMeth repInt "tryPutMVar" [ty] [repMVar ilxMethA,ilxMethA])
+ ilxCallSuppMeth repInt "tryPutMVar" [ty] [repMVar ilxMethTyVarA,ilxMethTyVarA])
{- MVar# s a -> State# s -> (# State# s, a #) -}
PutMVarOp -> ty2_op (\sty ty ->
- ilxCallSuppMeth (ilxOp "void") "putMVar" [ty] [repMVar ilxMethA, ilxMethA])
+ ilxCallSuppMeth (ilxOp "void") "putMVar" [ty] [repMVar ilxMethTyVarA, ilxMethTyVarA])
{- MVar# s a -> a -> State# s -> State# s -}
SameMVarOp -> ty2_op (\sty ty -> ilxCeq)
{- MVar# s a -> MVar# s a -> Bool -}
-- TakeMaybeMVarOp -> ty2_op (\sty ty ->
--- (ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethA) "tryTakeMVar" [ty] [repMVar ilxMethA]))
+-- (ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA]))
-- {- MVar# s a -> State# s -> (# State# s, Int#, a #) -}
IsEmptyMVarOp -> ty2_op (\sty ty ->
- ilxCallSuppMeth repInt "isEmptyMVar" [ty] [repMVar ilxMethA])
+ ilxCallSuppMeth repInt "isEmptyMVar" [ty] [repMVar ilxMethTyVarA])
{- MVar# s a -> State# s -> (# State# s, Int# #) -}
TouchOp -> warn_op "touch" (ty1_op (\ty1 -> ilxOp "pop /* PrimOp touch */ "))
{- a -> Int# -}
DataToTagOp -> ty1_op (\ty1 ->
- ilxCallSuppMeth repInt "dataToTag" [ty1] [ilxMethA])
+ ilxCallSuppMeth repInt "dataToTag" [ty1] [ilxMethTyVarA])
{- a -> Int# -}
TagToEnumOp -> ty1_op (\ty1 ->
- ilxCallSuppMeth ilxMethA "tagToEnum" [ty1] [repInt])
+ ilxCallSuppMeth ilxMethTyVarA "tagToEnum" [ty1] [repInt])
{- Int# -> a -}
MakeStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "box", ty1, ilxOp "newobj void", repStablePtr {- ty1 -}, ilxOp "::.ctor(class [mscorlib]System.Object)"])
EqStablePtrOp -> ty1_op (\ty1 -> ilxOp "ceq")
{- StablePtr# a -> StablePtr# a -> Int# -}
- MkWeakOp -> ty3_op (\ty1 ty2 ty3 -> ilxCall (ilxMethodRef (repWeak ilxMethB) classWeak "bake" [ty1,ty2,ty3] [ilxMethA, ilxMethB, ilxOp "!!2"]))
+ -- The 3rd argument to MkWeakOp is always a IO Monad action, i.e. passed as () --> ()
+ MkWeakOp -> ty3_op (\ty1 ty2 ty3 -> ilxCall (ilxMethodRef (repWeak ilxMethTyVarB) classWeak "bake" [ilxLift ty1,ilxLift ty2] [ilxMethTyVarA, ilxMethTyVarB, ilxLift (ilxTyIO ilxUnboxedEmptyRep)]))
{- o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) -}
- DeRefWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt ilxMethA) classWeak "deref" [ty1] [repWeak ilxMethA]))
- FinalizeWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt (ilxOp "(func ( /* unit skipped */ ) --> class '()')")) classWeak "finalizer" [ty1] [repWeak ilxMethA]))
+ DeRefWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt ilxMethTyVarA) classWeak "deref" [ty1] [repWeak ilxMethTyVarA]))
+ FinalizeWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt (ilxTyIO ilxUnboxedEmptyRep)) classWeak "finalizer" [ty1] [repWeak ilxMethTyVarA]))
{- Weak# a -> State# RealWorld -> (# State# RealWorld, Int#,
State# RealWorld -> (# State# RealWorld, Unit #)) #) -}
MkForeignObjOp -> simp_op (ilxOpSeq [ilxOp "newobj void", repForeign, ilxOp "::.ctor(void *)"])
WriteForeignObjOp -> ty1_op (\sty -> ilxOpSeq [ilxOp "stfld void *", repForeign, ilxOp "::contents"])
- ForeignObjToAddrOp -> simp_op ilxForeignToAddrOp
+ ForeignObjToAddrOp -> simp_op ilxAddrOfForeignOp
YieldOp -> simp_op (ilxOpSeq [ilxOp "call class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread()
call instance void class [mscorlib]System.Threading.Thread::Suspend()"])
MyThreadIdOp -> simp_op (ilxOpSeq [ilxOp "call default class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() "])
- KillThreadOp -> ty1_op (\ty -> ilxOpSeq [ilxOp "box", ty, ilxOp "call instance void class [mscorlib]System.Threading.Thread::Abort(class [mscorlib]System.Object) "])
+ -- This pushes a THUNK across as the exception value.
+ -- This is the correct Haskell semantics... TODO: we should probably
+ -- push across an HaskellThreadAbortException object that wraps this
+ -- thunk, but which is still actually an exception of
+ -- an appropriate type.
+ KillThreadOp -> ty1_op (\ty -> ilxOpSeq [ilxOp "call instance void class [mscorlib]System.Threading.Thread::Abort(class [mscorlib]System.Object) "])
{- ThreadId# -> a -> State# RealWorld -> State# RealWorld -}
ForkOp -> warn_op "ForkOp" (simp_op (ilxOp "/* ForkOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
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"))
ParGlobalOp -> warn_op "ParGlobalOp" (simp_op (ilxOp " /* ParGlobalOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
SeqOp -> warn_op "SeqOp" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw "))
AddrToHValueOp -> warn_op "AddrToHValueOp" (simp_op (ilxOp "newobj void [mscorlib]System.Object::.ctor() throw"))
- ReallyUnsafePtrEqualityOp -> simp_op (ilxOp "ceq")
+-- ReallyUnsafePtrEqualityOp -> simp_op (ilxOp "ceq")
MkApUpd0_Op -> warn_op "MkApUpd0_Op" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw"))
NewBCOOp -> warn_op "NewBCOOp" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw"))
-- ("newBCO#") [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy deltaTy, bcoPrimTy]))
+ _ -> pprPanic "Unimplemented primop" (ppr op)
ty1_op :: (IlxTyFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag
%************************************************************************
\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
+ text "call" <+> retdoc <+> pprCLabelString c <+> tyarg_doc
<+> 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
+ tyarg_doc | not (isEmptyVarSet (tyVarsOfTypes ty_args)) = text "/* type variable found */"
+ | otherwise = pprTypeArgs ilxTypeR env ty_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
isByteArrayCArgTy ty = hasTyCon ty byteArrayPrimTyCon || hasTyCon ty mutableByteArrayPrimTyCon
isByteArrayCArg v = isByteArrayCArgTy (deepIlxRepType (idType v))
-pinCCallArg v = isByteArrayCArg v
-ilxAddrOfPinnedByteArr = text "ldc.i4 0 ldelema unsigned int8"
+isForeignObjCArgTy ty = hasTyCon ty foreignObjPrimTyCon
+isForeignObjCArg v = isForeignObjCArgTy (deepIlxRepType (idType v))
+
+pinCCallArg v = isByteArrayCArg v || isForeignObjCArg v
-pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pushArg env arg <+> text "dup stloc" <+> singleQuotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") <+> ilxAddrOfPinnedByteArr
+pinCArg env arg v = pushArg env arg <+> text "dup stloc" <+> singleQuotes (ilxEnvQualifyByExact env (ppr v) <> text "pin")
+pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pinCArg env arg v <+> ilxAddrOfByteArrOp env
+pushCArg env arg@(StgVarArg v) | isForeignObjCArg v = pinCArg env arg v <+> ilxAddrOfForeignOp env
pushCArg env arg | otherwise = pushArg env arg
pprCValArgTys f env tys = parens (pprSepWithCommas (pprCValArgTy f env) tys)
pprCValArgTy f env ty | isByteArrayCArgTy ty = text "void *" <+> ilxComment (text "interior pointer into ByteArr#")
+pprCValArgTy f env ty | isForeignObjCArgTy ty = text "void *" <+> ilxComment (text "foreign object")
pprCValArgTy f env ty | otherwise = f env ty