Fri Mar 12 00:00:26 PST 2010  iavor.diatchki@gmail.com
  * FFI support for calling Haskell callbacks without adjustors.
  
  This patch extends Haskell's FFI with a new form of foreign import,
  the "static_wrapper".  These foreign imports are similar to "wrapper"
  imports, except that they do not generate code at run-time.
  Instead, they generate a C function which can evaluate Haskell
  values of a specified type.  This is sufficient for installing Haskell
  callbacks in C libraries that pass an additional "user data"
  argument to the callbacks (e.g., GTK). Example:
  
  -- The delaration:
  foreign import ccall "static_wrapper"
    c_handler :: Int -> IO Bool
  
  -- generates a C function of type:
  HsBool c_handler(HsInt, HsStablePtr);
  
  -- and them it is equivalent to an FFI declaration like this:
  foreign import ccall "&c_handler"
    c_handler :: FunPtr (Int -> StablePtr (Int -> IO Bool) -> IO Char)
  
  
  By default, the closure argument is the last argument in the C function.
  This can be changed by using a type variable to specify the location
  of the closure argument.  For example, this is how we can place the
  closure argument in the beginning:
  
  foreign import ccall "static_wrapper"
    c_handler :: closure -> Int -> IO Bool
  
  -- generates a C function of type:
  HsBool c_handler(HsStablePtr, HsInt);
  
  -- and a normal FFI declaration:
  foreign import ccall "&c_handler"
    c_handler :: FunPtr (StablePtr (Int -> IO Bool) -> Int -> IO Char)
  
  
  

New patches:

[FFI support for calling Haskell callbacks without adjustors.
iavor.diatchki@gmail.com**20100312080026
 Ignore-this: aa61aa1512c66acbb6a0afb958513f06
 
 This patch extends Haskell's FFI with a new form of foreign import,
 the "static_wrapper".  These foreign imports are similar to "wrapper"
 imports, except that they do not generate code at run-time.
 Instead, they generate a C function which can evaluate Haskell
 values of a specified type.  This is sufficient for installing Haskell
 callbacks in C libraries that pass an additional "user data"
 argument to the callbacks (e.g., GTK). Example:
 
 -- The delaration:
 foreign import ccall "static_wrapper"
   c_handler :: Int -> IO Bool
 
 -- generates a C function of type:
 HsBool c_handler(HsInt, HsStablePtr);
 
 -- and them it is equivalent to an FFI declaration like this:
 foreign import ccall "&c_handler"
   c_handler :: FunPtr (Int -> StablePtr (Int -> IO Bool) -> IO Char)
 
 
 By default, the closure argument is the last argument in the C function.
 This can be changed by using a type variable to specify the location
 of the closure argument.  For example, this is how we can place the
 closure argument in the beginning:
 
 foreign import ccall "static_wrapper"
   c_handler :: closure -> Int -> IO Bool
 
 -- generates a C function of type:
 HsBool c_handler(HsStablePtr, HsInt);
 
 -- and a normal FFI declaration:
 foreign import ccall "&c_handler"
   c_handler :: FunPtr (StablePtr (Int -> IO Bool) -> Int -> IO Char)
 
 
 
] {
hunk ./compiler/deSugar/DsForeign.lhs 156
   = dsFCall id (CCall (CCallSpec target cconv safety))
 dsCImport id CWrapper cconv _
   = dsFExportDynamic id cconv
+dsCImport id (CStaticWrapper n) cconv _
+  = dsFStaticWrapper id cconv n
 
 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
 -- then we need to calculate the size of the arguments in order to add
hunk ./compiler/deSugar/DsForeign.lhs 175
 \end{code}
 
 
+The following code generates a C functions which can be used to call
+a Haskell function of the specified type. We use a type variable to
+indicate the position of the function value parameter.  If the position
+of the closure is not specified with the type variable, then the closure
+is assumed to be the last argument the the calling function.
+
+\begin{verbatim}
+foregin import ccall "static wrapper" f :: Int -> closure -> Bool -> IO Char
+
+-- behaves like:
+
+foreign import ccall "&f"
+  f :: FunPtr (Int -> StablePtr (Int -> Bool -> IO Char) -> Bool -> IO Char)
+
+-- where "f" is the custom calling function, implemented in C:
+
+HsChar f(HsInt a1, HsStablePtr c, HsBool a2) {
+  Capability *cap;
+  HaskellObj ret;
+  HsChar cret;
+
+  cap = rts_lock();
+  cap = rts_evalIO(cap,
+          rts_apply
+            ( cap
+            , (HaskellObj)runIO_closure
+            , rts_apply
+                 ( cap
+                 , rts_apply
+                     ( cap
+                     , (StgClosure*)deRefStablePtr(c)
+                     , rts_mkInt(cap,a1)
+                     )
+                 , rst_mkBool(cap,a2)
+                 )
+            , &ret
+            );
+  rts_checkSchedStatus("f",cap);
+  cret = rts_getChar(ret);
+  rts_unlock(cap);
+  return cret;
+}
+\end{verbatim}
+
+\begin{code}
+dsFStaticWrapper :: Id -> CCallConv -> Int -> DsM ([Binding], SDoc, SDoc)
+dsFStaticWrapper f cc clo_pos =
+  let (_,funT)        = tcSplitForAllTys (idType f)
+      (args, io_res)  = tcSplitFunTys $ head $ snd $ tcSplitTyConApp funT
+
+      -- Find closure argument.
+      named_args  = zip [ text "a" <> int n | n <- [ 1 .. ] ] args
+      (clo_arg, fun_args) = let (xs,y:ys) = splitAt clo_pos named_args
+                            in (y, xs++ys)
+
+      -- We need to use a different "run" function, depending
+      -- on if the type is an IO one, or not.
+      (run_fun, resT)  = case tcSplitIOType_maybe io_res of
+                           Nothing      -> ("runNonIO_closure", io_res)
+                           Just (_,t,_) -> ("runIO_closure", t)
+
+      -- Functions returning (), or a newtype-ed () are mapped to "void".
+      (cRes, has_res)  = if resT `coreEqType` unitTy
+                              then (text "void", False)
+                              else (showStgType resT, True)
+
+
+      -- The signature for the genereated C function.
+      cArg (a,t) = cDecl (showStgType t) a
+      conv  = case cc of
+                CCallConv   -> empty
+                StdCallConv -> text (ccallConvAttribute cc)
+                _           -> panic ("dsFStaticWrapper/conv" ++ showPpr cc)
+
+      cName = toCName f
+      cSig  = cRes <+> conv <+> text cName <+> tuple (map cArg named_args)
+
+      -- Variables in the function.
+      cap           = text "cap"      -- capability
+      ret           = text "ret"      -- store result during evalution
+      cret          = text "cret"     -- result to be returned
+
+      -- Utilities to define the statement that performs the evaluation.
+      rtsApp f a   = cApp "rts_apply" [cap, f, a]
+      argVal (x,t) = cApp' (mkHObj t) [cap, x]
+      cloVal       = cApp' (cCast "StgClosure*" "deRefStablePtr") [fst clo_arg]
+
+      -- The body of the funciton.
+      stmts =
+        [ cDecl (text "Capability *") cap
+        , cDecl (text "HaskellObj")   ret
+        , cDecl cRes                 cret         `onlyIf` has_res
+
+        , cap =: cApp "rts_lock" []
+        , cap =: cApp "rts_evalIO"
+                   [ cap
+                   , rtsApp
+                      (cCast "HaskellObj" run_fun)
+                      (foldl (\f a -> rtsApp f (argVal a)) cloVal fun_args)
+                   , text "&" <> ret
+                   ]
+        , cApp "rts_checkSchedStatus" [doubleQuotes (text cName),cap]
+        , (cret =: cApp' (unpackHObj resT) [ret]) `onlyIf` has_res
+        , cApp "rts_unlock" [cap]
+        , cReturn cret                            `onlyIf` has_res
+        ]
+
+   in -- On the Haskell side
+      do (bs,hdr,c) <- dsCImport f (CLabel (mkFastString cName)) cc undefined
+         return ( bs
+                , hdr $$ cStmt cSig
+                , c $$ cSig <+> text "{" $$ nest 2 (vcat (map cStmt stmts))
+                                                                  $$ text "}"
+                )
+
+  where
+  x `onlyIf` b  = if b then x else empty
+  cApp' f xs    = f <> tuple xs
+  cApp f xs     = cApp' (text f) xs
+  cCast x y     = parens (text x) <> text y
+  cDecl x y     = x <+> y
+  cStmt s       = s <> semi
+  cReturn x     = text "return" <+> x
+  c =: e        = c <+> text "=" <+> e
+  tuple xs      = parens (hsep (punctuate comma xs))
+
+\end{code}
+
+
 %************************************************************************
 %*									*
 \subsection{Foreign calls}
hunk ./compiler/deSugar/DsMeta.hs 350
     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
     conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
     conv_cimportspec CWrapper = return "wrapper"
+    conv_cimportspec (CStaticWrapper _) = return "static_wrapper"
     static = case cis of
                  CFunction (StaticTarget _ _) -> "static "
                  _ -> ""
hunk ./compiler/hsSyn/HsDecls.lhs 919
 		 | CFunction CCallTarget      -- static or dynamic function
 		 | CWrapper		      -- wrapper to expose closures
 					      -- (former f.e.d.)
+		 | CStaticWrapper Int         -- wrapper to expose closures
+                                              -- without adjustors
 
 -- specification of an externally exported entity in dependence on the calling
 -- convention
hunk ./compiler/hsSyn/HsDecls.lhs 952
       pprCEntity (CFunction (DynamicTarget)) =
         ptext (sLit "dynamic")
       pprCEntity (CWrapper) = ptext (sLit "wrapper")
+      pprCEntity (CStaticWrapper _) = ptext (sLit "static_wrapper")
 
 instance Outputable ForeignExport where
   ppr (CExport  (CExportStatic lbl cconv)) = 
hunk ./compiler/parser/RdrHsSyn.lhs 947
        r <- choice [
           string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
           string "wrapper" >> return (mk nilFS CWrapper),
+          string "static_wrapper" >> return (mk nilFS (CStaticWrapper 0
+                              {- 0 is a dummy, value filled in during TC -})),
           optional (string "static" >> skipSpaces) >> 
            (mk nilFS <$> cimp nm) +++
            (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
hunk ./compiler/typecheck/TcForeign.lhs 44
 import SrcLoc
 import Bag
 import FastString
+import PrelNames(funPtrTyConName,stablePtrTyConName)
 \end{code}
 
 \begin{code}
hunk ./compiler/typecheck/TcForeign.lhs 71
   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
 
 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
+
+-- We do this one separately because we need to compute the type
+-- of the declared constant from the user-proivided template.
+tcFImport fo@(ForeignImport (L loc nm) hs_ty
+                          (CImport cconv safety h (CStaticWrapper _)))
+ = addErrCtxt (foreignDeclCtxt fo)  $
+   do sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+      let -- Drop the foralls before inspecting the
+          -- structure of the foreign type.
+	    (as, t_ty)	      = tcSplitForAllTys sig_ty
+	    (arg_tys, res_ty) = tcSplitFunTys t_ty
+
+            -- Find the position of the closure, indicated by a type variable.
+            (as1, args1, args2) =
+              case break tcIsTyVarTy arg_tys of
+                (xs,y:ys) -> (filter (/= v) as, xs, ys)
+                  where v = tcGetTyVar "tcIsTyVarTy == True for non-tyvar" y
+                (xs,[])   -> (as,xs,[])
+
+      -- Check that mentioned types are OK.
+      checkCg checkCOrAsmOrInterp
+      checkCConv cconv
+      checkSafety safety
+      checkForeignArgs isFFIExternalTy args1
+      checkForeignArgs isFFIExternalTy args2
+      checkForeignRes nonIOok isFFIExportResultTy res_ty
+
+      -- Now, compute the actual type of the declared constant
+      stablePtr <- tcLookupTyCon stablePtrTyConName
+      funPtr    <- tcLookupTyCon funPtrTyConName
+      let cloT = mkTyConApp stablePtr [mkFunTys (args1 ++ args2) res_ty]
+          funT = mkTyConApp funPtr [mkFunTys (args1 ++ [cloT] ++ args2) res_ty]
+	  id   = mkLocalId nm (mkForAllTys as1 funT)
+ 		-- Use a LocalId to obey the invariant that locally-defined
+		-- things are LocalIds.  However, it does not need zonking,
+		-- (so TcHsSyn.zonkForeignExports ignores it).
+
+         -- Can't use sig_ty here because sig_ty :: Type and
+	 -- we need HsType Id hence the undefined
+      return (id, ForeignImport (L loc id) undefined
+                    (CImport cconv safety h (CStaticWrapper (length args1))))
+
 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
  = addErrCtxt (foreignDeclCtxt fo)  $ 
    do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
}

Context:

[copy_tag_nolock(): fix write ordering and add a write_barrier()
Simon Marlow <marlowsd@gmail.com>**20100316143103
 Ignore-this: ab7ca42904f59a0381ca24f3eb38d314
 
 Fixes a rare crash in the parallel GC.
 
 If we copy a closure non-atomically during GC, as we do for all
 immutable values, then before writing the forwarding pointer we better
 make sure that the closure itself is visible to other threads that
 might follow the forwarding pointer.  I imagine this doesn't happen
 very often, but I just found one case of it: in scavenge_stack, the
 RET_FUN case, after evacuating ret_fun->fun we then follow it and look
 up the info pointer.
] 
[Add sliceP mapping to vectoriser builtins
benl@ouroborus.net**20100316060517
 Ignore-this: 54c3cafff584006b6fbfd98124330aa3
] 
[Comments only
benl@ouroborus.net**20100311064518
 Ignore-this: d7dc718cc437d62aa5b1b673059a9b22
] 
[TAG 2010-03-16
Ian Lynagh <igloo@earth.li>**20100316005137
 Ignore-this: 234e3bc29e2f26cc59d7b03d780cc352
] 
Patch bundle hash:
54e68be9009ea8366952b566c1a529247eb4ac1b
