import IdInfo ( arityLowerBound )
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, sourceTypeRep,
+ 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(..) )
import TysWiredIn ( mkTupleTy, tupleCon )
import PrimRep ( PrimRep(..) )
import Name ( nameModule, nameOccName, isGlobalName, isLocalName, NamedThing(getName) )
-import Subst ( substTy, mkTyVarSubst )
+import Subst ( substTyWith )
import Module ( Module, PackageName, ModuleName, moduleName,
modulePackage, preludePackage,
import Char ( ord )
import List ( partition, elem, insertBy,any )
import UniqSet
-import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
+import PprType ( pprType ) -- Only called in debug messages
import TysPrim ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
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 ".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
importsName env n
| isLocalName n = importsNone
- | ilxEnvModule env == nameModule 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 preludePackage
+
+
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
importsTyCon env tc | (not (isDataTyCon tc) ||
isLocalName (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)
+
+
+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) ||
+ isLocalName (getName tc) ||
+ ilxEnvModule env == nameModule (getName tc)) = importsNone
+importsTyConDataConTypeTyCon env tc | otherwise = importsName env (getName tc)
-importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC")
- | otherwise = addPackageImpInfo preludePackage
type StaticCCallInfo = (CLabelString,CCallConv,[Type],Type)
type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon, UniqFM StaticCCallInfo)
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
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 unmanaged preservesig { }"
+ 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 "import" else empty) <+> tyvars_text <+> text ": thunk"
- <> angleBrackets((nameReference env (getName tycon)) <> (ppr tycon)) <+> 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
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 (place, StgRhsClosure _ _ fvs _ args _) -> Just (place,fun,args,fvs)
- _ -> trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun))) Nothing
+ _ -> Nothing -- trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun)))
type KnownClosure = Maybe ( IlxEnv -- Of the binding site of the function
, Id -- The function
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)
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 (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))
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
_ -> 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 (SourceTy p) = deepIlxRepType (sourceTypeRep p)
deepIlxRepType ty@(TyVarTy tv) = ty
idIlxRepType id = deepIlxRepType (idType id)
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
-- 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
-- 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
+ -- See hack above
| isVanillaModule m && not inPrelude = preludePackageReference
| isVanillaModule m && inPrelude = moduleNameReference (moduleName m)
--- end hack
+ -- end hack
| otherwise = packageReference (modulePackage m)
preludePackageReference = packageReference preludePackage
-- ForeignObj: load the address inside the object first
-- TODO: is this remotely right?
+ 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"])
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
-- We also do some type-directed translation for pinning Haskell-managed blobs
-- of data as we throw them across the boundary.
ilxFCall env (CCall (CCallSpec (StaticTarget c) cconv gc)) args ret_ty
- = ilxComment (text "C call <+> pprCLabelString c") <+>
+ = 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 | isVoidIlxRepType ret_ty = text "void"
+ retdoc | isVoidIlxRepType ret_ty = text "void"
| otherwise = ilxTypeR env (deepIlxRepType ret_ty)
- (ty_args,tm_args) = splitTyArgs1 args
+ (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 pushILArg env tm_args),
+ 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
where
(ty_args,tm_args) = splitTyArgs1 args
-pushILArg env arg | isUnLiftedType (stgArgType arg) = pushArg env arg
- | otherwise = pushArg env arg <+> text "EVAL!"
+-- 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