From: dsyme <unknown>
Date: Fri, 25 May 2001 16:14:02 +0000 (+0000)
Subject: [project @ 2001-05-25 16:14:02 by dsyme]
X-Git-Tag: Approximately_9120_patches~1867
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d67b0a6c9d54f6c6e4672fd3db85e726fd89f1dd;p=ghc-hetmet.git

[project @ 2001-05-25 16:14:02 by dsyme]
Minor tweaks to IlxGen backend
---

diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs
index 2a8eabe..ad36bac 100644
--- a/ghc/compiler/ilxGen/IlxGen.lhs
+++ b/ghc/compiler/ilxGen/IlxGen.lhs
@@ -238,9 +238,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 
@@ -728,7 +729,15 @@ ilxFunApp env fun args tail_call
 	--	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 =
@@ -1127,10 +1136,9 @@ deepIlxRepType ty@(TyConApp tc tys)
 	 Just rep_ty -> 
            let res = deepIlxRepType (applyTys rep_ty tys) in 
            if not (length tys == tyConArity tc ) then 
-             pprTrace "deepIlxRepType" (text "length tys <> tyConArity tc, ty = " <+> pprType ty <+> text ", length tys = " <+> ppr (length tys) <+> text ", tyConArity = " <+> ppr (tyConArity tc)) res 
+             --pprTrace "deepIlxRepType" (text "length tys <> tyConArity tc, ty = " <+> pprType ty <+> text ", length tys = " <+> ppr (length tys) <+> text ", tyConArity = " <+> ppr (tyConArity tc)) 
+             res 
            else res
-		-- The assert should hold because deepIlxRepType should
-		-- only be applied to *types* (of kind *)
 	 Nothing     -> 
            -- collapse UnboxedTupleTyCon down when it contains VoidRep types.
 	   -- e.g. 	(# State#, Int#, Int# #)  ===>   (# Int#, Int# #)
@@ -2293,7 +2301,7 @@ ilxFCall env (CCall (CCallSpec (StaticTarget c) cconv gc)) args ret_ty
 
 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 +2310,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
diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index a656c38..fff6722 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -128,7 +128,7 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety))
 
   | otherwise 		-- Normal foreign import
   = checkCg (if isCasmTarget target
-	     then checkC else checkCOrAsm)			`thenNF_Tc_`
+	     then checkC else checkCOrAsmOrDotNet)			`thenNF_Tc_`
     checkCTarget target						`thenNF_Tc_`
     getDOptsTc							`thenNF_Tc` \ dflags ->
     checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys	`thenNF_Tc_`
@@ -137,7 +137,7 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety))
 -- This makes a convenient place to check
 -- that the C identifier is valid for C
 checkCTarget (StaticTarget str) 
-  = checkCg checkCOrAsm 	`thenNF_Tc_`
+  = checkCg checkCOrAsmOrDotNet 	`thenNF_Tc_`
     check (isCLabelString str) (badCName str)
 
 checkCTarget (CasmTarget _)
@@ -243,6 +243,11 @@ checkCOrAsm HscC   = Nothing
 checkCOrAsm HscAsm = Nothing
 checkCOrAsm other  = Just (text "via-C or native code generation (-fvia-C)")
 
+checkCOrAsmOrDotNet HscC   = Nothing
+checkCOrAsmOrDotNet HscAsm = Nothing
+checkCOrAsmOrDotNet HscILX = Nothing
+checkCOrAsmOrDotNet other  = Just (text "requires C, native or .NET ILX code generation")
+
 checkCg check
  = getDOptsTc		`thenNF_Tc` \ dflags ->
    case check (dopt_HscLang dflags) of