import Name ( nameModule, nameOccName, isGlobalName, isLocalName, isDllName, NamedThing(getName) )
import Subst ( substTy, mkTyVarSubst )
-import Module ( Module, PackageName, ModuleName, moduleName, modulePackage, preludePackage,
- isHomeModule, pprModuleName, mkHomeModule, mkModuleName
+import Module ( Module, PackageName, ModuleName, moduleName,
+ modulePackage, preludePackage,
+ isPrelModule, isHomeModule, isVanillaModule,
+ pprModuleName, mkHomeModule, mkModuleName
)
import UniqFM
]
where
binds = map fst binds_w_srts
- (import_packages,import_modules,import_tycons) = importsBinds binds `unionImpInfo` importsPrelude
+ (import_packages,import_modules,import_tycons) = importsBinds binds (importsPrelude emptyImpInfo)
toppairs = ilxPairs binds
topenv = extendIlxEnvWithTops (emptyIlxEnv False mod) mod toppairs
-- Generate info from class decls as well
\begin{code}
-importsBinds :: [StgBinding] -> ImportsInfo
-importsBinds binds = unionImpInfos (map importsBind binds)
+importsBinds :: [StgBinding] -> ImportsInfo-> ImportsInfo
+importsBinds binds = foldR importsBind binds
-importsBind :: StgBinding -> ImportsInfo
-importsBind (StgNonRec _ b rhs) = importsRhs rhs `unionImpInfo` importsVar b
-importsBind (StgRec _ pairs) = unionImpInfos (map (\(b,rhs) -> importsRhs rhs `unionImpInfo` importsVar b) pairs)
+importsNone :: ImportsInfo -> ImportsInfo
+importsNone sofar = sofar
-importsRhs (StgRhsCon _ con args) = importsDataCon con `unionImpInfo` importsStgArgs args
-importsRhs (StgRhsClosure _ _ _ upd args body) = importsExpr body `unionImpInfo` importsVars args
+importsBind :: StgBinding -> ImportsInfo -> ImportsInfo
+importsBind (StgNonRec _ b rhs) = importsRhs rhs.importsVar b
+importsBind (StgRec _ pairs) = foldR (\(b,rhs) -> importsRhs rhs . importsVar b) pairs
-importsExpr :: StgExpr -> ImportsInfo
-importsExpr (StgLit l) = emptyImpInfo
-importsExpr (StgApp f args) = importsVar f `unionImpInfo` importsStgArgs args
-importsExpr (StgConApp con args) = importsDataCon con `unionImpInfo` importsStgArgs args
-importsExpr (StgPrimApp op args res_ty) = importsType res_ty `unionImpInfo` importsStgArgs args
+importsRhs (StgRhsCon _ con args) = importsDataCon con . importsStgArgs args
+importsRhs (StgRhsClosure _ _ _ upd args body) = importsExpr body. importsVars args
+
+importsExpr :: StgExpr -> ImportsInfo -> ImportsInfo
+importsExpr (StgLit l) = importsNone
+importsExpr (StgApp f args) = importsVar f.importsStgArgs args
+importsExpr (StgConApp con args) = importsDataCon con.importsStgArgs args
+importsExpr (StgPrimApp op args res_ty) = importsType res_ty. importsStgArgs args
importsExpr (StgSCC cc expr) = importsExpr expr
importsExpr (StgCase scrut _ _ bndr srt alts)
- = importsExpr scrut `unionImpInfo` imports_alts alts `unionImpInfo` importsVar bndr
+ = importsExpr scrut. imports_alts alts. importsVar bndr
where
imports_alts (StgAlgAlts _ alts deflt) -- The Maybe TyCon part is dealt with
-- by the case-binder's type
- = unionImpInfos (map imports_alg_alt alts) `unionImpInfo` imports_deflt deflt
+ = foldR imports_alg_alt alts . imports_deflt deflt
where
imports_alg_alt (con, bndrs, _, rhs)
- = importsExpr rhs `unionImpInfo` importsDataCon con `unionImpInfo` importsVars bndrs
+ = importsExpr rhs . importsDataCon con. importsVars bndrs
imports_alts (StgPrimAlts _ alts deflt)
- = unionImpInfos (map imports_prim_alt alts) `unionImpInfo` imports_deflt deflt
+ = foldR imports_prim_alt alts . imports_deflt deflt
where
imports_prim_alt (lit, rhs) = importsExpr rhs
- imports_deflt StgNoDefault = emptyImpInfo
+ imports_deflt StgNoDefault = importsNone
imports_deflt (StgBindDefault rhs) = importsExpr rhs
+
importsExpr (StgLetNoEscape _ _ bind body) = importsExpr (StgLet bind body)
importsExpr (StgLet bind body)
- = importsBind bind `unionImpInfo` importsExpr body
+ = importsBind bind . importsExpr body
-importsApp v args = importsVar v `unionImpInfo` importsStgArgs args
-importsStgArgs args = unionImpInfos (map importsStgArg args)
+importsApp v args = importsVar v. importsStgArgs args
+importsStgArgs args = foldR importsStgArg args
-importsStgArg :: StgArg -> ImportsInfo
+importsStgArg :: StgArg -> ImportsInfo -> ImportsInfo
importsStgArg (StgTypeArg ty) = importsType ty
importsStgArg (StgVarArg v) = importsVar v
-importsStgArg _ = emptyImpInfo
+importsStgArg _ = importsNone
-importsVars vs = unionImpInfos (map importsVar vs)
-importsVar v = importsName (idName v) `unionImpInfo` importsType (idType v)
+importsVars vs = foldR importsVar vs
+importsVar v = importsName (idName v). importsType (idType v)
importsName n
- | isLocalName n = emptyImpInfo
- | thisModule == nameModule n = emptyImpInfo
- | isDllName n = singlePackageImpInfo (modulePackage (nameModule n))
- | otherwise = singleModuleImpInfo (moduleName (nameModule n))
+ | isLocalName n = importsNone
+ | thisModule == nameModule n = importsNone
+ | isHomeModule (nameModule n) = addModuleImpInfo (moduleName (nameModule n))
+ | isVanillaModule (nameModule n) = addPackageImpInfo preludePackage
+ | otherwise = addPackageImpInfo (modulePackage (nameModule n))
+
importsModule m
- | thisModule == m = emptyImpInfo
- | isHomeModule m = singleModuleImpInfo (moduleName m)
- | otherwise = singlePackageImpInfo (modulePackage m)
+ | thisModule == m = importsNone
+ | isHomeModule m = trace "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\n" (addModuleImpInfo (moduleName m))
+ | isVanillaModule m = addPackageImpInfo preludePackage
+ | otherwise = addPackageImpInfo (modulePackage m)
-importsType :: Type -> ImportsInfo
+importsType :: Type -> ImportsInfo -> ImportsInfo
importsType ty = importsType2 (deepIlxRepType ty)
-importsType2 :: Type -> ImportsInfo
-importsType2 (AppTy f x) = importsType2 f `unionImpInfo` importsType2 x
-importsType2 (TyVarTy _) = emptyImpInfo
-importsType2 (TyConApp tc args) =importsTyCon tc `unionImpInfo` importsTypeArgs2 args
-importsType2 (FunTy arg res) = importsType arg `unionImpInfo` importsType2 res
+importsType2 :: Type -> ImportsInfo -> ImportsInfo
+importsType2 (AppTy f x) = importsType2 f . importsType2 x
+importsType2 (TyVarTy _) = importsNone
+importsType2 (TyConApp tc args) =importsTyCon tc . importsTypeArgs2 args
+importsType2 (FunTy arg res) = importsType arg . importsType2 res
importsType2 (ForAllTy tv body_ty) = importsType2 body_ty
importsType2 (NoteTy _ ty) = importsType2 ty
-importsTypeArgs2 tys =unionImpInfos (map importsType2 tys)
+importsTypeArgs2 tys = foldR importsType2 tys
importsDataCon dcon = importsTyCon (dataConTyCon dcon)
-importsMaybeTyCon Nothing = emptyImpInfo
+importsMaybeTyCon Nothing = importsNone
importsMaybeTyCon (Just tc) = importsName (getName tc)
importsTyCon tc | (not (isDataTyCon tc) ||
isLocalName (getName tc) ||
- thisModule == nameModule (getName tc)) = emptyImpInfo
-importsTyCon tc | otherwise = importsName (getName tc) `unionImpInfo` (emptyUniqSet, emptyUniqSet,unitUniqSet tc)
+ thisModule == nameModule (getName tc)) = importsNone
+importsTyCon tc | otherwise = importsName (getName tc) . addTyConImpInfo tc
-importsPrelude | preludePackage == opt_InPackage = singleModuleImpInfo (mkModuleName "PrelGHC")
- | otherwise = singlePackageImpInfo preludePackage
+importsPrelude | preludePackage == opt_InPackage = addModuleImpInfo (mkModuleName "PrelGHC")
+ | otherwise = addPackageImpInfo preludePackage
-type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon) -- (Packages, Modules, Datatypes)
+type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon)
+ -- (Packages, Modules, Datatypes)
emptyImpInfo :: ImportsInfo
emptyImpInfo = (emptyUniqSet, emptyUniqSet, emptyUniqSet)
-singlePackageImpInfo p = (unitUniqSet p, emptyUniqSet, emptyUniqSet)
-singleModuleImpInfo m = (emptyUniqSet, unitUniqSet m, emptyUniqSet)
-
-unionImpInfo :: ImportsInfo -> ImportsInfo -> ImportsInfo
-unionImpInfo (w1,x1,y1) (w2,x2,y2) = (unionUniqSets w1 w2, unionUniqSets x1 x2, unionUniqSets y1 y2)
-
-unionImpInfos :: [ImportsInfo] -> ImportsInfo
-unionImpInfos fvs = foldr unionImpInfo emptyImpInfo fvs
+addPackageImpInfo p (w,x,y) = (addOneToUniqSet w p, x, y)
+addModuleImpInfo m (w,x,y) = (w, addOneToUniqSet x m, y)
+addTyConImpInfo tc (w,x,y) = (w, x, addOneToUniqSet y tc)
ilxImportTyCon :: IlxEnv -> TyCon -> SDoc
ilxImportTyCon env tycon | isDataTyCon tycon = pprIlxTyConDef True env tycon
closure_sig_text =
- vcat [(case args of
- [] -> empty
+ vcat [ text "()",
+ (case args of
+ [] -> empty
other -> args_text),
text "-->" <+> rty_text]
-- We could probably omit some void argument binders, but
-- don't...
pprArgBinder env arg
- | isVoidIlxRepId arg = (text "()", extendIlxEnvWithArgs env [arg])
+ | isVoidIlxRepId arg = (text "(unit)", extendIlxEnvWithArgs env [arg])
| otherwise
= if isTyVar arg then
let env' = extendIlxEnvWithTyArgs env [arg] in
-- Recurse until we're done.
ilxFunAppArgs env num_sofar funty args tail_call known_clo
= vcat [vcat (ilxMapPlaceArgs num_sofar pushArgWithVoids env now_args),
- call_instr <+> now_args_text
+ call_instr <+> text "()" <+> now_args_text
<+> text "-->"
<+> (pprIlxTypeR env_after_now_tyvs later_ty),
later
]
where
- now_args_text = hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys)
+ now_args_text =
+ case now_arg_tys of
+ [] -> empty
+ _ -> hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys)
(now_args,now_arg_tys,env_after_now_tyvs,later_args,later_ty) =
case args of
pushId_aux :: Bool -> IlxEnv -> Id -> SDoc
pushId_aux voids _ id | isVoidIlxRepId id =
- if voids then text "ldvoid" else ilxComment (text "pushId: void rep skipped")
+ if voids then text "ldunit" else ilxComment (text "pushId: void rep skipped")
pushId_aux _ env var
= case lookupIlxVarEnv env var of
Just Arg -> text "ldarg" <+> pprId var
-- Get rid of all NoteTy and NewTy artifacts
deepIlxRepType :: Type -> Type
-
--- Eliminate state variables on left of arrow types...
--- We have to be careful not to erase too much information here -
--- the type may not accurately describe
--- the "functionness" of the result. For example,
--- State# -> Int#
--- reduces to
--- Int#
--- which looks like an unboxed type. It isn't - it's
--- just a function taking no arguments. As such, we
--- have to rely on the context in which a function type is being
--- used to know what to do.
---
--- deepIlxRepType (FunTy l r) | isVoidIlxRepType l
--- = deepIlxRepType r
-
deepIlxRepType (FunTy l r)
= FunTy (deepIlxRepType l) (deepIlxRepType r)
idIlxRepType id = deepIlxRepType (idType id)
--------------------------
--- Function types and type functions are implicitly thunkable.
-- Some primitive type constructors are not thunkable.
-- Everything else needs to be marked thunkable.
pprIlxTypeL :: IlxEnv -> Type -> SDoc
-pprIlxTypeL env ty | isVoidIlxRepType ty
- = trace "pprIlxTypeL: VoidRep" pprIlxTypeR env ty
-
-pprIlxTypeL env ty@(FunTy arg res)
- = pprIlxTypeR env ty
-
-pprIlxTypeL env ty@(ForAllTy arg res)
- = pprIlxTypeR env ty
-
-pprIlxTypeL env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc)
- = ilxComment (text "what the fuck?") <+> (pprIlxTypeR env ty)
-pprIlxTypeL env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc)))
- = pprIlxTypeR env ty
-
-pprIlxTypeL env ty | isUnLiftedType ty -- must come after cases above because isUnLiftedType strips Forall's
- = pprIlxTypeR env ty
-
-pprIlxTypeL env ty
- = text "thunk" <> angleBrackets (pprIlxTypeR env ty)
+pprIlxTypeL env ty | isUnLiftedType ty || isVoidIlxRepType ty = pprIlxTypeR env ty
+pprIlxTypeL env ty = text "thunk" <> angleBrackets (pprIlxTypeR env ty)
--------------------------
-- Print non-thunkable version of type.
--
pprIlxTypeR :: IlxEnv -> Type -> SDoc
-pprIlxTypeR env ty | isVoidIlxRepType ty = text "void"
-pprIlxTypeR env ty = pprIlxTypeR2 env ty
-
-pprIlxTypeR2 env ty@(AppTy f _) | isTyVarTy f = ilxComment (text "type app:" <+> pprId ty) <+> (text "class [mscorlib]System.Object")
-pprIlxTypeR2 env ty@(AppTy f x) = trace "pprIlxTypeR: should I be beta reducing types?!" (ilxComment (text "pprIlxTypeR: should I be beta reducing types...") <+> pprIlxTypeR env (applyTy f x))
-pprIlxTypeR2 env (TyVarTy tv) = pprIlxTyVar env tv
+pprIlxTypeR env ty | isVoidIlxRepType ty = text "unit"
+pprIlxTypeR env ty@(AppTy f _) | isTyVarTy f = ilxComment (text "type app:" <+> pprId ty) <+> (text "class [mscorlib]System.Object")
+pprIlxTypeR env ty@(AppTy f x) = trace "pprIlxTypeR: should I be beta reducing types?!" (ilxComment (text "pprIlxTypeR: should I be beta reducing types...") <+> pprIlxTypeR env (applyTy f x))
+pprIlxTypeR env (TyVarTy tv) = pprIlxTyVar env tv
-- The following is a special rule for types constructed out of
-- higher kinds, e.g. Monad f or Functor f.
-- The code below is not as general as it should be, but as I
-- have no idea if this approach will even work, I'm going to
-- just try it out on some simple cases arising from the prelude.
-pprIlxTypeR2 env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc)
+pprIlxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc)
= ilxComment (text "what the fuck? 2") <+> (pprIlxTypeR env (TyConApp tc t))
-pprIlxTypeR2 env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc)))
+pprIlxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc)))
= pprIlxTypeR env (TyConApp tc t)
-pprIlxTypeR2 env (TyConApp tc args) = pprIlxTyConApp env tc args
+pprIlxTypeR env (TyConApp tc args) = pprIlxTyConApp env tc args
-- nb. the only legitimate place for VoidIlxRepTypes to occur in normalized IlxRepTypes
-- is on the left of an arrow
-- We could probably eliminate all but a final occurrence of these.
- --pprIlxTypeR2 env (FunTy arg res@(FunTy _ _)) | isVoidIlxRepType arg
- -- = pprIlxTypeR env res
-pprIlxTypeR2 env (FunTy arg res) | isVoidIlxRepType arg
- = parens (text "func () -->" <+> pprIlxTypeR env res)
-pprIlxTypeR2 env (FunTy arg res)
+pprIlxTypeR env (FunTy arg res)
= pprIlxFunTy (pprIlxTypeL env arg) (pprIlxTypeR env res)
-pprIlxTypeR2 env ty@(ForAllTy tv body_ty) | isIlxTyVar tv
+pprIlxTypeR env ty@(ForAllTy tv body_ty) | isIlxTyVar tv
= parens (text "forall" <+> pprTyVarBinders env' [tv] <+> nest 2 (pprIlxTypeR env' body_ty))
where
env' = extendIlxEnvWithFormalTyVars env [tv]
-pprIlxTypeR2 env ty@(ForAllTy tv body_ty) | otherwise
+pprIlxTypeR env ty@(ForAllTy tv body_ty) | otherwise
= ilxComment (text "higher order type var " <+> pprId tv) <+>
pprIlxFunTy (text "class [mscorlib]System.Object") (pprIlxTypeR env body_ty)
-pprIlxTypeR2 env (NoteTy _ ty)
+pprIlxTypeR env (NoteTy _ ty)
= trace "WARNING! non-representation type given to pprIlxTypeR: see generated ILX for context where this occurs"
(vcat [text "/* WARNING! non-representation type given to pprIlxTypeR! */",
pprIlxTypeR env ty ])
-
pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran])
pprIlxTyConApp env tc args =
hscOptionQual = if opt_SimplDoEtaReduction then text ".O" else text ".Onot"
nameReference (IlxEnv (thisMod, _, _, _, _, _)) n
- | isLocalName n = text "/* local */"
+ | isLocalName n = empty
| thisMod == nameModule n = text ""
- | isDllName n = brackets ((text "ilx") <+> singleQuotes (ppr (modulePackage (nameModule n)) <> hscOptionQual))
- | otherwise = brackets ((text ".module") <+> (text "ilx") <+> singleQuotes (pprModuleName (moduleName (nameModule n)) <> hscOptionQual))
+ | isHomeModule (nameModule n) = moduleNameReference (moduleName (nameModule n))
+ | isVanillaModule (nameModule n) = packageReference preludePackage
+ | 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))
moduleReference (IlxEnv (thisMod, _, _, _, _, _)) m
| thisMod == m = text ""
- | isHomeModule m = brackets ((text ".module") <+> (text "ilx") <+> singleQuotes (pprModuleName (moduleName m) <> hscOptionQual))
- | otherwise = brackets ((text "ilx") <+> singleQuotes (ppr (modulePackage m) <> hscOptionQual))
-
-prelGHCReference =
- if preludePackage == opt_InPackage then brackets (text ".module ilx PrelGHC" <> hscOptionQual)
- else brackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual)
-
-prelBaseReference =
- if preludePackage == opt_InPackage then brackets (text ".module ilx PrelBase" <> hscOptionQual)
- else brackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual)
+ | isHomeModule m = moduleNameReference (moduleName m)
+ | isVanillaModule m = packageReference preludePackage
+ | otherwise = packageReference (modulePackage m)
------------------------------------------------
-- This code is copied from absCSyn/CString.lhs,
\end{code}
+
%************************************************************************
%* *
-\subsection{C Calls}
+\subsection{PrimOps}
%* *
%************************************************************************
\begin{code}
--- We eliminate voids in and around an IL C Call. We don't yet emit PInvoke stubs.
--- 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") <+>
- vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args),
- text "call" <+> retdoc <+> text "class " <+> prelGHCReference <+> text "PrelGHC::" <+> pprCLabelString c <+> pprTypeArgs pprIlxTypeR env ty_args
- <+> pprCValArgTys pprIlxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ]
- where
- retdoc =
- if isVoidIlxRepType ret_ty then text "void"
- else pprIlxTypeR env (deepIlxRepType ret_ty)
- (ty_args,tm_args) = splitTyArgs1 args
-
-
-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"
-
-pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pushArg env arg <+> text "dup stloc" <+> squotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") <+> ilxAddrOfPinnedByteArr
-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 | otherwise = f env ty
+prelGHCReference =
+ if preludePackage == opt_InPackage then
+ brackets (text ".module ilx PrelGHC" <> hscOptionQual)
+ else brackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual)
-\end{code}
-%************************************************************************
-%* *
-\subsection{PrimOps}
-%* *
-%************************************************************************
+prelBaseReference =
+ if preludePackage == opt_InPackage then
+ brackets (text ".module ilx PrelBase" <> hscOptionQual)
+ else brackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual)
-\begin{code}
ilxPrimApp env (CCallOp ccall) args ret_ty = ilxCCall env ccall args ret_ty
ilxPrimApp env op args ret_ty = ilxPrimOpTable op env args
RaiseOp -> ty2_op (\ty1 ty2 -> text "throw")
CatchOp -> ty2_op (\ty1 ty2 ->
- text "call" <+> ilxSuppMeth ilxMethA "catch" [ty1,ty2] [text "(func () --> !!0)", text "(func (!!1) --> (func () --> !!0))"])
+ text "call" <+> ilxSuppMeth ilxMethA "catch" [ty1,ty2] [text "(func (unit) --> !!0)", text "(func (!!1) --> (func (unit) --> !!0))"])
{- (State# RealWorld -> (# State# RealWorld, a #) )
-> (b -> State# RealWorld -> (# State# RealWorld, a #) )
-> State# RealWorld
-}
BlockAsyncExceptionsOp -> ty1_op (\ty1 ->
- text "call" <+> ilxSuppMeth ilxMethA "blockAsyncExceptions" [ty1] [text "(func () --> !!0)"])
+ text "call" <+> ilxSuppMeth ilxMethA "blockAsyncExceptions" [ty1] [text "(func (unit) --> !!0)"])
{- (State# RealWorld -> (# State# RealWorld, a #))
-> (State# RealWorld -> (# State# RealWorld, a #))
-}
UnblockAsyncExceptionsOp -> ty1_op (\ty1 ->
- text "call" <+> ilxSuppMeth ilxMethA "unblockAsyncExceptions" [ty1] [text "(func () --> !!0)"])
+ text "call" <+> ilxSuppMeth ilxMethA "unblockAsyncExceptions" [ty1] [text "(func (unit) --> !!0)"])
{-
State# RealWorld -> (# State# RealWorld, a #))
text "call" <+> ilxSuppMeth ilxMethA "takeMVar" [ty] [repMVar ilxMethA])
{- MVar# s a -> State# s -> (# State# s, a #) -}
+ -- These aren't yet right
+ TryTakeMVarOp -> ty2_op (\sty ty ->
+ text "call" <+> ilxSuppMeth ilxMethA "tryTakeMVar" [ty] [repMVar ilxMethA])
+ {- MVar# s a -> State# s -> (# State# s, a #) -}
+
+ TryPutMVarOp -> ty2_op (\sty ty ->
+ text "call" <+> ilxSuppMeth ilxMethA "tryPutMVar" [ty] [repMVar ilxMethA])
+ {- MVar# s a -> State# s -> (# State# s, a #) -}
+
PutMVarOp -> ty2_op (\sty ty ->
text "call" <+> ilxSuppMeth (text "void") "putMVar" [ty] [repMVar ilxMethA, ilxMethA])
{- MVar# s a -> a -> State# s -> State# s -}
{- o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) -}
DeRefWeakOp -> ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "!0")) (repWeak ty1) "deref" [] [])
- FinalizeWeakOp -> ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "(func () --> class '()')")) (repWeak ty1) "finalizer" [] [])
+ FinalizeWeakOp -> ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "(func (unit) --> class '()')")) (repWeak ty1) "finalizer" [] [])
{- Weak# a -> State# RealWorld -> (# State# RealWorld, Int#,
State# RealWorld -> (# State# RealWorld, Unit #)) #) -}
simp_op op env args = vcat (ilxMapPlaceArgs 0 pushArg env args) $$ op
warn_op warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ warning) (f args)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{C Calls}
+%* *
+%************************************************************************
+
+\begin{code}
+
+-- We eliminate voids in and around an IL C Call. We don't yet emit PInvoke stubs.
+-- 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") <+>
+ vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args),
+ text "call" <+> retdoc <+> text "class " <+> prelGHCReference <+> text "PrelGHC::" <+> pprCLabelString c <+> pprTypeArgs pprIlxTypeR env ty_args
+ <+> pprCValArgTys pprIlxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ]
+ where
+ retdoc =
+ if isVoidIlxRepType ret_ty then text "void"
+ else pprIlxTypeR env (deepIlxRepType ret_ty)
+ (ty_args,tm_args) = splitTyArgs1 args
+
+
+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"
+
+pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pushArg env arg <+> text "dup stloc" <+> squotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") <+> ilxAddrOfPinnedByteArr
+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 | otherwise = f env ty
+
+
+foldR :: (a -> b -> b) -> [a] -> b -> b
+-- foldR _ [] z = z
+-- foldR f (x:xs) z = f x (foldR f xs z)
+{-# INLINE foldR #-}
+foldR k xs z = go xs
+ where
+ go [] = z
+ go (y:ys) = y `k` go ys
+
+\end{code}
+
-include ../../../lib/std/Makefile.src
# These settings are if you use a visual studio build
CVS=cvs
CORENV_RETAIL=
LOCALRUN=./
ILX_FAST=x
-ifeq ($(HOSTNAME),msrc-hilda)
-CORENV_DEBUG="call devvsnearerb1gen.bat"
-CORENV_RETAIL="call devvsnearerb1gen.bat retail"
+ifeq ($(HOSTNAME),MSRC-HILDA)
+CORENV_DEBUG="call devcorb2gen.bat fastchecked"
+CORENV_RETAIL="call devcorb2gen.bat free"
LOCALRUN=.\\
ILX_FAST=
endif
-ILXASM_HOME=C:/devel/fcom/src
-ILXASM=$(ILXASM_HOME)/bin/ilxasm$(ILX_FAST).exe
-ILVALID=$(ILXASM_HOME)/bin/ilvalid$(ILX_FAST).exe
-ILXASM_FLAGS=-l $(ILXASM_HOME)/ilxasm --no-ilasm --tailcall-indirect
+ILX2IL_HOME=C:/devel/fcom/src
+ILX2IL=$(ILX2IL_HOME)/bin/ilx2il.opt.exe
+ILVALID=$(ILX2IL_HOME)/bin/ilvalid.opt.exe
ghc:
- $(MAKE) -C ../.. ghc
+ $(MAKE) -C ../..
-ilxasm:
- $(MAKE) -C $(ILXASM_HOME) bin/ilxasm.exe
+ilx:
+ $(MAKE) -C $(ILX2IL_HOME) ilxdefault
-ilxasmx:
- $(MAKE) -C $(ILXASM_HOME) bin/ilxasmx.exe
-
-ilvalid:
- $(MAKE) -C $(ILXASM_HOME) bin/ilvalid.exe
-
-ilvalidx:
- $(MAKE) -C $(ILXASM_HOME) bin/ilvalidx.exe
-
-prel:
- $(MAKE) -C ../../../lib/std ilxasm std.Onot.nongeneric.boxed.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.dll
-
-prelq:
- $(MAKE) -C ../../../lib/std ilxasm std.Onot.nongeneric.boxed.trial.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.trial.dll
-
-oprel:
- $(MAKE) -C ../../../lib/std ilxasm std.O.nongeneric.boxed.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.dll
-
-oprelq:
- $(MAKE) -C ../../../lib/std ilxasm std.O.nongeneric.boxed.trial.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.trial.dll
-
-tprel:
- $(MAKE) -C ../../../lib/std ilxasm std.Onot.nongeneric.boxed.traced.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.traced.dll
-
-otprel:
- $(MAKE) -C ../../../lib/std ilxasm std.O.nongeneric.boxed.traced.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.traced.dll
-
-#gprel:
-# $(MAKE) -C ../../../lib/std ilxasm std.Onot.generic.dll
-# $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.generic.dll
-#
-#ogprel:
-# $(MAKE) -C ../../../lib/std ilxasm std.O.generic.dll
-# $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.generic.dll
-#
-#gtprel:
-# $(MAKE) -C ../../../lib/std ilxasm std.Onot.generic.traced.dll
-# $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.generic.traced.dll
-
-vgprel:
- $(MAKE) -C ../../../lib/std ilxasm std.Onot.vmeth-erased.generic.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.dll
-
-ovgprel:
- $(MAKE) -C ../../../lib/std ilxasm std.O.vmeth-erased.generic.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.dll
-
-ovgprelq:
- $(MAKE) -C ../../../lib/std ilxasm std.O.vmeth-erased.generic.trial.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.trial.dll
-
-vgtprel:
- $(MAKE) -C ../../../lib/std ilxasm std.Onot.vmeth-erased.generic.traced.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.traced.dll
-
-ovgtprel:
- $(MAKE) -C ../../../lib/std ilxasm std.O.vmeth-erased.generic.traced.dll
- $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.traced.dll
+prel: ilx
+ $(MAKE) -C ../../../lib/std std.Onot.mono-b2.dll
%.o: %.hs ../../ghc-4.11
../../ghc-inplace -o $@ -c $*.hs
-std_NONGENERIC_STATIC_IL=$(patsubst %.lhs,../../../lib/std/%.nongeneric.boxed.static.il,$(std_SRC)) ../../../lib/std/PrelGHC.nongeneric.boxed.static.il
-std_GENERIC_STATIC_IL=$(patsubst %.lhs,../../../lib/std/%.generic.static.il,$(std_SRC)) ../../../lib/std/PrelGHC.generic.static.il
-
#========================================================================
# 1. From Haskell to ILX
%.Onot.ilx: %.hs ../../ghc-4.11
- ../../ghc-inplace -c -fglasgow-exts -o $@ -i../../../lib/std/.Onot -Onot -filx $*.hs -osuf Onot.ilx
+ ../../ghc-inplace -c -fglasgow-exts -o $@ -i../../../lib/std/.Onot -Onot -filx -fkeep-stg-types $*.hs -osuf Onot.ilx
%.O.ilx: %.hs ../../ghc-4.11
- ../../ghc-inplace -c -fglasgow-exts -o $@ -i../../../lib/std/.O -O -filx $*.hs -osuf O.ilx
+ ../../ghc-inplace -c -fglasgow-exts -o $@ -i../../../lib/std/.O -O -filx -fkeep-stg-types $*.hs -osuf O.ilx
../Entry.Onot.ilx: ../Entry.ilx
sed -e "s|ilx std|ilx std.Onot|g" ../Entry.ilx > $@.tmp
mv $@.tmp $@
-%.Onot.dlllib.ilx: %.Onot.ilx ../Entry.Onot.ilx
- cat ../Entry.Onot.ilx $*.Onot.ilx > $@.tmp
- mv $@.tmp $@
-
../Entry.O.ilx: ../Entry.ilx
sed -e "s|ilx std|ilx std.O|g" ../Entry.ilx > $@.tmp
mv $@.tmp $@
-%.O.dlllib.ilx: %.O.ilx ../Entry.O.ilx
- cat ../Entry.O.ilx $*.O.ilx > $@.tmp
- mv $@.tmp $@
-
-HSstd_cbits.dll: ../../../lib/std/cbits/HSstd_cbits.dll
- cp $< $@
-
#========================================================================
# 2. From ILX to IL
-#------------------------------------------------------------------------
-# Compile for a vanilla VM against a vanilla library organised as a
-# seperate assembly/DLL.
-
-%.nongeneric.boxed.dlllib.il: $(ILXASM) %.dlllib.ilx
- $(ILXASM) --box-everything --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx
- mv $@.tmp $@
-
-#------------------------------------------------------------------------
-# Same
-# - running a trial optimization
-# - for traced code on a vanilla VM
-%.nongeneric.boxed.trial.dlllib.il: $(ILXASM) %.dlllib.ilx
- $(ILXASM) --trial-opt --box-everything --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx
+%.generic.il: $(ILX2IL) %.ilx
+ $(ILX2IL) --generic $(ILX2IL_FLAGS) -o $@.tmp $*.ilx
mv $@.tmp $@
-%.nongeneric.boxed.traced.dlllib.il: $(ILXASM) %.dlllib.ilx
- $(ILXASM) --box-everything --trace-il --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx
+%.mono.il: $(ILX2IL) %.ilx
+ $(ILX2IL) --mono $(ILX2IL_FLAGS) -o $@.tmp $*.ilx
mv $@.tmp $@
#------------------------------------------------------------------------
-# Same, for a generic library and generic VM
-
-%.generic.dlllib.il: $(ILXASM) %.dlllib.ilx
- $(ILXASM) --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx
- mv $@.tmp $@
-
-%.generic.trial.dlllib.il: $(ILXASM) %.dlllib.ilx
- $(ILXASM) --trial-opt --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx
- mv $@.tmp $@
-
-%.generic.traced.dlllib.il: $(ILXASM) %.dlllib.ilx
- $(ILXASM) --trace-il --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx
- mv $@.tmp $@
-
-%.vmeth-erased.generic.dlllib.il: $(ILXASM) %.dlllib.ilx
- $(ILXASM) --poly-virtual-method-erase --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx
- mv $@.tmp $@
-
-%.vmeth-erased.generic.trial.dlllib.il: $(ILXASM) %.dlllib.ilx
- $(ILXASM) --trial-opt --poly-virtual-method-erase --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx
- mv $@.tmp $@
-
-%.vmeth-erased.generic.traced.dlllib.il: $(ILXASM) %.dlllib.ilx
- $(ILXASM) --poly-virtual-method-erase --trace-il --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx
- mv $@.tmp $@
-
-
-#------------------------------------------------------------------------
-# Compile for a vanilla VM against a vanilla library compiled to IL code
-# to be statically linked as one big module. We hack this up by textually
-# stripping out all the assembly qualifications (apart from mscorlib)
-# from the ILX forward files and IL code itself. We then just
-# concatenate all the IL code together and compile it as a single .EXE.
-
-%.staticlib.ilx: %.ilx ../Entry.ilx
- cat ../Entry.ilx $*.ilx | \
- sed -e "sQ\[std\]QQg" | \
- sed -e "sQ\['std'\]QQg" > $@.tmp
- cat $@.tmp > $@.tmp2
- mv $@.tmp2 $@
- rm $@.tmp
-
-
-%.generic.staticlib.il: $(ILXASM) %.staticlib.ilx
- $(ILXASM) --static --no-pp $(ILXASM_FLAGS) -o $@.tmp $*.staticlib.ilx
- cat $(std_GENERIC_STATIC_IL) $@.tmp > $@.tmp2
- mv $@.tmp2 $@
- rm $@.tmp
-
-
-%.nongeneric.boxed.staticlib.il: $(ILXASM) %.staticlib.ilx
- $(ILXASM) --box-everything --static $(ILXASM_FLAGS) -o $@.tmp $*.staticlib.ilx
- cat $(std_NONGENERIC_STATIC_IL) $@.tmp > $@.tmp2
- mv $@.tmp2 $@
- rm $@.tmp
-
-
-#------------------------------------------------------------------------
-# For compiling test cases that don't use the standard library at all.
-
-%.nolib.ilx: %.ilx PrelBase.test.ilx ../PrelGHC.ilx ../Entry.ilx
- cat ../PrelGHC.ilx PrelBase.test.ilx ../Entry.ilx $*.ilx > $@.tmp
- mv $@.tmp $@
-
-%.nolib.il: $(ILXASM) $(ILXASM_HOME)/ilxasm/stdlib-func-by-mcalli.ilx %.nolib.ilx
- $(ILXASM) $(ILXASM_FLAGS) -o $@.tmp $*.nolib.ilx
- mv $@.tmp $@
-
-%.nolib.traced.il: $(ILXASM) $(ILXASM_HOME)/ilxasm/stdlib-func-by-mcalli.ilx %.nolib.ilx
- $(ILXASM) --trace-il $(ILXASM_FLAGS) $*.nolib.ilx > $@.tmp
- mv $@.tmp $@
-
-
-#------------------------------------------------------------------------
# From IL to .EXE
-%.retail.exe: %.il ../Entry.Onot.mono.il
- cat %.il ../Entry.Onot.mono.il > $@.tmp
+%.generic.exe: %.generic.il ../Entry.Onot.generic.il
+ cat $*.generic.il ../Entry.Onot.generic.il > $@.tmp
echo "$(CORENV_RETAIL)" > $@.bat
- echo "ilasm -exe -quiet -out=$(subst /,\\,$@.tmp) $(subst /,\\,$<)" >> $@.bat
+ echo "ilasm /exe /quiet /out=$(subst /,\\,$@.tmp) $(subst /,\\,$@.tmp)" >> $@.bat
time -p cmd /c $(subst /,\\,$@).bat
rm $@.bat
-%.debug.exe: %.il
+%.mono.exe: %.mono.il ../Entry.Onot.mono.il
+ cat $*.mono.il ../Entry.Onot.mono.il > $@.tmp
echo "$(CORENV_RETAIL)" > $@.bat
- echo "ilasm -exe -quiet -debug -out=$(subst /,\\,$@) $(subst /,\\,$<)" >> $@.bat
+ echo "ilasm /exe /quiet /out=$(subst /,\\,$@.tmp) $(subst /,\\,$@.tmp)" >> $@.bat
time -p cmd /c $(subst /,\\,$@).bat
rm $@.bat
+
#------------------------------------------------------------------------
# From .HS to .EXE without using ILX
# Used to run performance comparisons against native code GHC
%.O.exe: %.hs
ghc -O -o $@ $<
-%.o: %.hs ../../hsc.exe
- ../../../driver/ghc-inplace -o $@ -c $*.hs
-
%.run: %.exe
time -p $<
#------------------------------------------------------------------------
# Running:
-%.debug.run: HSstd_cbits.dll %.debug.exe
+HSstd_cbits.dll: ../../../lib/std/cbits/HSstd_cbits.dll
+ cp $< $@
+
+%.debug.run: HSstd_cbits.dll %.exe
echo "$(CORENV_DEBUG)" > $@.bat
- echo "set CORPATH=$(subst /,\\,$(ILXASM_HOME))\\bin;\\GHC\\fptools\\ghc\\lib\\std;%CORPATH%" >> $@.bat
+ echo "set CORPATH=$(subst /,\\,$(ILX2IL_HOME))\\bin;\\GHC\\fptools\\ghc\\lib\\std;%CORPATH%" >> $@.bat
echo "$(LOCALRUN)$(subst /,\\,$*).debug.exe 2>&1" >> $@.bat
time -p cmd /c $(subst /,\\,$@).bat
rm $@.bat
-%.retail.run: HSstd_cbits.dll %.retail.exe
+%.retail.run: HSstd_cbits.dll %.exe
echo "$(CORENV_RETAIL)" > $@.bat
- echo "set CORPATH=$(subst /,\\,$(ILXASM_HOME))\\bin;\\GHC\\fptools\\ghc\\lib\\std;%CORPATH%" >> $@.bat
+ echo "set CORPATH=$(subst /,\\,$(ILX2IL_HOME))\\bin;\\GHC\\fptools\\ghc\\lib\\std;%CORPATH%" >> $@.bat
echo "$(LOCALRUN)$(subst /,\\,$*).retail.exe 2>&1" >> $@.bat
time -p cmd /c $(subst /,\\,$@).bat
rm $@.bat
time -p $<
-
#--------------------
-%.debug.exe: %.nolib.il
- echo "$(CORENV_RETAIL)" > $@.bat
- echo "$(CORENV_RETAIL)ilasm /DEBUG /OUT=$(subst /,\\,$@) $(subst /,\\,$<)" >> $@.bat
- time -p cmd /c $(subst /,\\,$@).bat
- rm $@.bat
-
-%.trace-il.nolib.il: $(ILXASM) $(ILXASM_HOME)/ilxasm/stdlib-func-by-mcalli.ilx %.nolib.ilx
- $(ILXASM) $(ILXASM_FLAGS) --trace-il $*.nolib.ilx > $@.tmp
- mv $@.tmp $@
-
%.mvl: %.nolib.il
- ILVALID_HOME=$(ILXASM_HOME) $(ILVALID) $*.nolib.il
+ ILVALID_HOME=$(ILX2IL_HOME) $(ILVALID) $*.nolib.il
ci:
- (cd $(ILXASM_HOME); $(CVS) ci -m "")
+ (cd $(ILX2IL_HOME); $(CVS) ci -m "")
(cd ../..; cvs ci -m "")
(cd ../../../lib/std; $(CVS) ci -m "")
upd:
- (cd $(ILXASM_HOME); $(CVS) up)
+ (cd $(ILX2IL_HOME); $(CVS) up)
(cd ../..; $(CVS) up)
(cd ../../../lib/std; $(CVS) up)
-.PRECIOUS: %.nongeneric.boxed.dlllib.il %.generic.dlllib.il %.generic.il %.nolib.il %.Onot.ilx %.O.ilx %.nolib.ilx %.dlllib.ilx %.exe %.debug.exe %.dll %.O.exe
+.PRECIOUS: %.mono-nonstatic.il %.fullgeneric-nonstatic.il %.fullgeneric.il %.nolib.il %.Onot.ilx %.O.ilx %.nolib.ilx %-nonstatic.ilx %.exe %.debug.exe %.dll %.O.exe
.PHONY: %.run
projects / ghc-hetmet.git / commitdiff