[project @ 2002-02-21 14:42:17 by sewardj]

In DsForeign.fexportEntry, track recent changes to f-x-dynamic
implementation.  At the same time completely rewrite this fn, since I
couldn't figure out how the previous incarnation worked.

ghc/compiler/deSugar/DsForeign.lhs

@@ -97,7 +97,7 @@ dsForeigns mod_name fos
     = dsFExport mod_name id (idType id) 
 		ext_nm cconv False                 `thenDs` \(feb, b, h, c) ->
       warnDepr depr loc				   `thenDs` \_              ->
-      returnDs (feb:acc_feb, b : acc_f, h $$ acc_h, c $$ acc_c, acc_header)
+      returnDs (feb:acc_feb, b:acc_f, h $$ acc_h, c $$ acc_c, acc_header)
 
   warnDepr False _   = returnDs ()
   warnDepr True  loc = dsWarn (addShortWarnLocLine loc msg)
@@ -325,8 +325,9 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn
       	the_body = mkLams (tvs ++ wrapper_args) the_app
   
       	(h_stub, c_stub) = fexportEntry (moduleUserString mod)
-      				      	ext_name f_helper_glob
-                                      	wrapper_arg_tys res_ty cconv isDyn
+      				      	ext_name 
+                                        (if isDyn then Nothing else Just f_helper_glob)
+                                      	fe_arg_tys res_ty cconv
      in
      returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
 
@@ -381,7 +382,7 @@ dsFExportDynamic mod_name id cconv
         -- hack: need to get at the name of the C stub we're about to generate.
        fe_nm	   = _PK_ (moduleUserString mod_name ++ "_" ++ toCName fe_id)
      in
-     dsFExport mod_name id export_ty fe_nm cconv True  	`thenDs` \ (feb, fe, h_code, c_code) ->
+     dsFExport mod_name id export_ty fe_nm cconv True  	`thenDs` \ ({-feb-}_, {-fe-}_, h_code, c_code) ->
      newSysLocalDs arg_ty				`thenDs` \ cback ->
      dsLookupGlobalValue newStablePtrName		`thenDs` \ newStablePtrId ->
      let
@@ -426,7 +427,7 @@ dsFExportDynamic mod_name id cconv
 		-- Never inline the f.e.d. function, because the litlit
 		-- might not be in scope in other modules.
      in
-     returnDs ([fed, fe], h_code, c_code)
+     returnDs ([fed] {-[fed, fe]-}, h_code, c_code)
 
  where
   ty			= idType id
@@ -453,23 +454,79 @@ using the hugs/ghc rts invocation API.
 \begin{code}
 fexportEntry :: String
 	     -> FAST_STRING
-	     -> Id 
+	     -> Maybe Id 	-- Just==static, Nothing==dynamic
 	     -> [Type] 
 	     -> Type 
 	     -> CCallConv 
-	     -> Bool
 	     -> (SDoc, SDoc)
-fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
+fexportEntry mod_nm c_nm maybe_target arg_htys res_hty cc = (header_bits, c_bits)
  where
-   -- name of the (Haskell) helper function generated by the desugarer.
-  h_nm	    = ppr helper <> text "_closure"
-   -- prototype for the exported function.
+  -- Create up types and names for the real args
+  arg_cnames, arg_ctys :: [SDoc]
+  arg_cnames = mkCArgNames 1 arg_htys
+  arg_ctys   = map showStgType arg_htys
+
+  -- and also for auxiliary ones; the stable ptr in the dynamic case, and
+  -- a slot for the dummy return address in the dynamic + ccall case
+  extra_cnames_and_ctys
+     = case maybe_target of
+          Nothing -> [(text "the_stableptr", text "StgStablePtr")]
+          other   -> []
+       ++
+       case (maybe_target, cc) of
+          (Nothing, CCallConv) -> [(text "original_return_addr", text "void*")]
+          other                -> []
+
+  all_cnames_and_ctys :: [(SDoc, SDoc)]
+  all_cnames_and_ctys 
+     = extra_cnames_and_ctys ++ zip arg_cnames arg_ctys
+
+  -- stuff to do with the return type of the C function
+  res_hty_is_unit = res_hty `eqType` unitTy	-- Look through any newtypes
+
+  cResType | res_hty_is_unit = text "void"
+	   | otherwise	     = showStgType res_hty
+
+  -- Now we can cook up the prototype for the exported function.
+  pprCconv = case cc of
+		CCallConv   -> empty
+		StdCallConv -> text (ccallConvAttribute cc)
+
   header_bits = ptext SLIT("extern") <+> fun_proto <> semi
 
   fun_proto = cResType <+> pprCconv <+> ptext c_nm <>
-	      parens (hsep (punctuate comma (zipWith (<+>) cParamTypes proto_args)))
-
+	      parens (hsep (punctuate comma (map (\(nm,ty) -> ty <+> nm) 
+                                                 all_cnames_and_ctys)))
+
+  -- the target which will form the root of what we ask rts_evalIO to run
+  the_cfun
+     = case maybe_target of
+          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
+          Just hs_fn -> ppr hs_fn <> text "_closure"
+
+  -- the expression we give to rts_evalIO
+  expr_to_run
+     = foldl appArg the_cfun (zip arg_cnames arg_htys)
+       where
+          appArg acc (arg_cname, arg_hty) 
+             = text "rts_apply" 
+               <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname)
+
+  -- various other bits for inside the fn
+  declareResult = text "HaskellObj ret;"
+
+  return_what | res_hty_is_unit = empty
+	      | otherwise       = parens (unpackHObj res_hty <> parens (text "ret"))
+
+  -- an extern decl for the fn being called
+  extern_decl
+     = case maybe_target of
+          Nothing -> empty
+          Just hs_fn -> text "extern StgClosure* " <> ppr hs_fn <> text "_closure" <> semi
+
+  -- finally, the whole darn thing
   c_bits =
+    extern_decl $$
     fun_proto  $$
     vcat 
      [ lbrace
@@ -477,11 +534,7 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
      ,   declareResult
 	  -- create the application + perform it.
      ,   text "rc=rts_evalIO" 
-         <> parens (foldl appArg (text "(StgClosure*)deRefStablePtr(a0)") 
-                                 (tail (zip args c_args))
-                    <> comma 
-                    <> text "&ret"
-                   ) 
+         <> parens (expr_to_run <+> comma <> text "&ret")
          <> semi
      ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ptext c_nm)
 						<> comma <> text "rc") <> semi
@@ -489,42 +542,6 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
      , rbrace
      ]
 
-  appArg acc (a,c_a) =
-     text "rts_apply" <> parens (acc <> comma <> mkHObj a <> parens c_a)
-
-  cParamTypes  = map showStgType real_args
-
-  res_ty_is_unit = res_ty `eqType` unitTy	-- Look through any newtypes
-
-  cResType | res_ty_is_unit = text "void"
-	   | otherwise	    = showStgType res_ty
-
-  pprCconv = case cc of
-		CCallConv   -> empty
-		StdCallConv -> text (ccallConvAttribute cc)
-     
-  declareResult  = text "HaskellObj ret;"
-
-  mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
-
-  return_what | res_ty_is_unit = empty
-	      | otherwise      = parens (unpackHObj res_ty <> parens (text "ret"))
-
-  c_args = mkCArgNames 0 args
-
-  {-
-   If we're generating an entry point for a 'foreign export ccall dynamic',
-   then we receive the return address of the C function that wants to
-   invoke a Haskell function as any other C function, as second arg.
-   This arg is unused within the body of the generated C stub, but
-   needed by the Adjustor.c code to get the stack cleanup right.
-  -}
-  (proto_args, real_args)
-    = case cc of
-	CCallConv | isDyn -> ( text "a0" : text "original_return_addr" 
-                                         : mkCArgNames 1 (tail args)
-			     , head args : addrTy : tail args)
-        other		  -> (mkCArgNames 0 args, args)
 
 mkCArgNames :: Int -> [a] -> [SDoc]
 mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..]