X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FilxGen%2FIlxGen.lhs;h=b08131871a8c4fc474b5a2891cbd469e9344f59f;hb=fd4b0e845bd83be9eaf050b113f8df51cee6b082;hp=2a8eabe683fd664f794cfaf9911b765cd63581d8;hpb=3af411e913102d8ec1234f32abe99374f077e3f7;p=ghc-hetmet.git diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 2a8eabe..b081318 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -12,15 +12,16 @@ import Id ( idType, idName, isDeadBinder, idArityInfo ) 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(..) ) @@ -28,7 +29,7 @@ import ForeignCall ( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget( 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, @@ -43,7 +44,7 @@ import Outputable 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 ) @@ -67,7 +68,8 @@ import CmdLineOpts ( opt_InPackage, opt_SimplDoEtaReduction ) 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))), @@ -92,7 +94,7 @@ ilxGen mod tycons binds_w_srts \begin{code} -importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo-> ImportsInfo +importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo -> ImportsInfo importsBinds env binds = foldR (importsBind env) binds importsNone :: ImportsInfo -> ImportsInfo @@ -154,7 +156,7 @@ importsVar env v = importsName env (idName v). importsType env (idType v) 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 @@ -163,11 +165,15 @@ importsName env n | 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 @@ -181,10 +187,31 @@ importsDataCon env dcon = importsTyCon env (dataConTyCon dcon) 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) @@ -202,10 +229,10 @@ ilxImportTyCon env tycon | isDataTyCon tycon = ilxTyConDef True env tycon 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 @@ -214,7 +241,7 @@ ilxImportCCall env (c,cc,args,ret) = 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" @@ -238,9 +265,10 @@ ilxTyCon env tycon = ilxTyConDef False env tycon -- 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 @@ -584,7 +612,7 @@ ilxWipe env ids 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 ) @@ -728,14 +756,22 @@ ilxFunApp env fun args tail_call -- ldloc x arg of type Int -- .tail callfunc (!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 (!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 @@ -802,7 +838,7 @@ ilxFunAppArgs env num_sofar funty args tail_call known_clo 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) @@ -1083,7 +1119,7 @@ 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 (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)) @@ -1106,11 +1142,7 @@ pprIlxTopVar env 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) @@ -1123,16 +1155,7 @@ deepIlxRepType (FunTy l r) = 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 @@ -1141,10 +1164,10 @@ deepIlxRepType ty@(TyConApp tc tys) _ -> 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) @@ -1165,7 +1188,7 @@ ilxTypeL env ty = text "thunk" <> angleBrackets (ilxTypeR env ty) 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 @@ -1246,9 +1269,9 @@ pprTyVarBinder_aux env tv = -- 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) @@ -1419,7 +1442,7 @@ singleQuotes pp = char '\'' <> pp <> char '\'' line = text "// ----------------------------------" -hscOptionQual = if opt_SimplDoEtaReduction then text ".ilx-O" else text ".ilx-Onot" +hscOptionQual = text ".i_" nameReference env n | isLocalName n = empty @@ -1434,16 +1457,16 @@ nameReference env 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 + -- 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 @@ -1990,6 +2013,7 @@ ilxPrimOpTable op -- 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"]) @@ -2212,6 +2236,7 @@ ilxPrimOpTable op 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 @@ -2282,18 +2307,20 @@ warn_op warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ w -- 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 @@ -2302,8 +2329,11 @@ ilxFCall env (DNCall (DNCallSpec call_instr)) args ret_ty 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