A declaration for an ÒwrapperÓ callback looks like this: 

    foreign import ccall safe "wrapper" 
        mkDelegate :: IO () -> IO (FunPtr (IO ()))

To implement these, GHC normally generates a small piece of executable code at
runtime, called an ÒadjustorÓ.  The purpose of these ÒwrapperÓ declarations is
to generate a C-callable function pointer that executes a Haskell closure.

Apple has a code-signing policy, that says that all code that runs on the iPhone
must be signed by Apple.  GHC wants to generate code at runtime, and this can't
be signed by Apple.  This is enforced by the iPhone's kernel, so GHC's standard
implementation is impossible.

This iPhone port solves the problem by pre-compiling a pool of functions, and
allocating from it. 

If the pool is too small for a given application, you can increase it by using a
{-# POOLSIZE x #-} pragma, which must appear after the "wrapper" token.  e.g.

    foreign import ccall safe "wrapper" {-# POOLSIZE 100 #-} 
        mkDelegate :: IO () -> IO (FunPtr (IO ())) 

==================
Changes to the compiler to achieve the above
See also 16-rts-adjustor-pool.patch

--- ghc-6.10.2.orig/compiler/deSugar/DsForeign.lhs	2009-03-31 06:13:16.000000000 +1300
+++ ghc-6.10.2/compiler/deSugar/DsForeign.lhs	2009-06-18 15:54:37.000000000 +1200
@@ -89,7 +89,7 @@
       return (h, c, [], bs)
 
    do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) = do
-      (h, c, _, _) <- dsFExport id (idType id) ext_nm cconv False
+      (h, c, _, _) <- dsFExport id (idType id) ext_nm cconv False 32
       return (h, c, [id], [])
 
    do_decl d = pprPanic "dsForeigns/do_decl" (ppr d)
@@ -157,8 +157,8 @@
 
 dsCImport id (CFunction target) cconv safety
   = dsFCall id (CCall (CCallSpec target cconv safety))
-dsCImport id CWrapper cconv _
-  = dsFExportDynamic id cconv
+dsCImport id (CWrapper poolCapacity) cconv _
+  = dsFExportDynamic id cconv poolCapacity
 
 -- 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
@@ -268,13 +268,14 @@
 	  -> Bool		-- True => foreign export dynamic
 				-- 	   so invoke IO action that's hanging off 
 				-- 	   the first argument's stable pointer
+          -> Int                -- iPhone: Function pool capacity
 	  -> DsM ( SDoc		-- contents of Module_stub.h
 		 , SDoc		-- contents of Module_stub.c
 		 , String       -- string describing type to pass to createAdj.
 		 , Int		-- size of args to stub function
 		 )
 
-dsFExport fn_id ty ext_name cconv isDyn=  do
+dsFExport fn_id ty ext_name cconv isDyn poolCapacity =  do
     let
        (_tvs,sans_foralls)             = tcSplitForAllTys ty
        (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
@@ -298,7 +299,7 @@
     return $
       mkFExportCBits ext_name 
                      (if isDyn then Nothing else Just fn_id)
-                     fe_arg_tys res_ty is_IO_res_ty cconv
+                     fe_arg_tys res_ty is_IO_res_ty cconv poolCapacity
 \end{code}
 
 @foreign import "wrapper"@ (previously "foreign export dynamic") lets
@@ -334,8 +335,9 @@
 \begin{code}
 dsFExportDynamic :: Id
 		 -> CCallConv
+                 -> Int  -- iPhone: Function pool capacity
 		 -> DsM ([Binding], SDoc, SDoc)
-dsFExportDynamic id cconv = do
+dsFExportDynamic id cconv poolCapacity = do
     fe_id <-  newSysLocalDs ty
     mod <- getModuleDs
     let
@@ -350,7 +352,7 @@
         export_ty     = mkFunTy stable_ptr_ty arg_ty
     bindIOId <- dsLookupGlobalId bindIOName
     stbl_value <- newSysLocalDs stable_ptr_ty
-    (h_code, c_code, typestring, args_size) <- dsFExport id export_ty fe_nm cconv True
+    (h_code, c_code, typestring, args_size) <- dsFExport id export_ty fe_nm cconv True poolCapacity
     let
          {-
           The arguments to the external function which will
@@ -363,10 +365,12 @@
                         , Var stbl_value
                         , Lit (MachLabel fe_nm mb_sz_args IsFunction)
                         , Lit (mkMachString typestring)
+                        , Lit (mkMachString $ unpackFS fe_nm)
+                        , Lit (MachLabel (fe_nm `appendFS` fsLit "_pool") Nothing IsData )
                         ]
           -- name of external entry point providing these services.
           -- (probably in the RTS.) 
-        adjustor   = fsLit "createAdjustor"
+        adjustor   = fsLit "iPhoneCreateAdjustor"
         
           -- Determine the number of bytes of arguments to the stub function,
           -- so that we can attach the '@N' suffix to its label if it is a
@@ -423,12 +427,13 @@
 	       -> Type 
                -> Bool		-- True <=> returns an IO type
 	       -> CCallConv 
+               -> Int           -- iPhone: Number of function pool entries
 	       -> (SDoc, 
 		   SDoc,
 		   String, 	-- the argument reps
 		   Int		-- total size of arguments
 		  )
-mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 
+mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc poolCapacity
  = (header_bits, c_bits, type_string,
     sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
     )
@@ -451,7 +456,8 @@
         | otherwise = text ('a':show n)
 
   -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
-  libffi = cLibFFI && isNothing maybe_target
+  --libffi = cLibFFI && isNothing maybe_target
+  libffi = False  -- iPhone: Use non-libffi style.
 
   type_string
       -- libffi needs to know the result type too:
@@ -464,7 +470,8 @@
   -- add some auxiliary args; the stable ptr in the wrapper case, and
   -- a slot for the dummy return address in the wrapper + ccall case
   aug_arg_info
-    | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
+    -- -- | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
+    | isNothing maybe_target = stable_ptr_arg : arg_info  -- iPhone: No dummy return address
     | otherwise              = arg_info
 
   stable_ptr_arg = 
@@ -483,12 +490,20 @@
 		StdCallConv -> text (ccallConvAttribute cc)
                 CmmCallConv -> panic "mkFExportCBits/pprCconv CmmCallConv"
 
-  header_bits = ptext (sLit "extern") <+> fun_proto <> semi
+  header_bits = ptext (sLit "extern") <+> fun_proto <> semi $$
+         (if isNothing maybe_target
+             then text "extern " <> pool_decl <> semi
+             else empty)
 
-  fun_args
-    | null aug_arg_info = text "void"
+
+  mkEntryName idx = text (unpackFS c_nm ++ "_entry" ++ show idx) 
+
+  fun_args = fun_args_ aug_arg_info
+  
+  fun_args_ args
+    | null args = text "void"
     | otherwise         = hsep $ punctuate comma
-                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
+                               $ map (\(nm,ty,_,_) -> ty <+> nm) args
 
   fun_proto
     | libffi
@@ -528,7 +543,9 @@
           Nothing -> empty
           Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
 
-   
+  pool_decl =
+      text "void* " <> ftext c_nm <> text "_pool[" <> text (show (poolCapacity*2+1)) <> text "]"
+
   -- finally, the whole darn thing
   c_bits =
     space $$
@@ -564,7 +581,38 @@
                        ptext (sLit "resp = cret;")
                   else ptext (sLit "return cret;")
      , rbrace
-     ]
+     ] $$ (
+         if isNothing maybe_target
+             then pool
+             else empty)
+
+  pool =   
+     -- iPhone: Due to Apple's code signing policy, we can't do self-modifying
+     -- code on the iPhone.  So instead, we pre-compile a pool of adjustors.
+     text "extern StgStablePtr iPhoneLookupAdjustor(void*)" <> semi $$
+     text "extern " <> pool_decl <> semi $$
+     vcat (
+         flip map [0..poolCapacity-1] $ \poolIdx ->
+             cResType <+> mkEntryName poolIdx <> parens (fun_args_ arg_info) $$
+             lbrace $$ (
+                 (if res_hty_is_unit
+                     then empty
+                     else text "return ") <>
+                 ftext c_nm <> parens (
+                     text "iPhoneLookupAdjustor" <> parens (
+                         ftext c_nm <> text "_pool+" <> text (show (poolIdx :: Int)) <> text "*2")
+                     <> (if null arg_info
+                         then empty
+                         else comma <+> hsep (punctuate comma $ map (\(nm,ty,_,_) -> nm) arg_info))
+                 ) <> semi
+             ) $$ rbrace
+     ) $$
+     pool_decl <> text " = " <> lbrace $$
+     vcat (punctuate comma $
+             flip map [0..poolCapacity-1] $ \poolIdx ->
+                 text "  " <> mkEntryName poolIdx <> comma <+> text "NULL"
+         ) <> comma $$
+     text "  NULL" <> rbrace <> semi
 
 
 foreignExportInitialiser :: Id -> SDoc
@@ -613,6 +661,7 @@
 	    Just (tc,_) -> tc
 	    Nothing	-> pprPanic "showFFIType" (ppr t)
 
+{-
 insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, MachRep)]
                            -> [(SDoc, SDoc, Type, MachRep)]
 #if !defined(x86_64_TARGET_ARCH)
@@ -633,6 +682,7 @@
 	 go _ [] = []
 insertRetAddr _ args = args
 #endif
+-}
 
 ret_addr_arg :: (SDoc, SDoc, Type, MachRep)
 ret_addr_arg = (text "original_return_addr", text "void*", undefined, 
--- ghc-6.10.2.orig/compiler/deSugar/DsMeta.hs	2009-03-31 06:13:15.000000000 +1300
+++ ghc-6.10.2/compiler/deSugar/DsMeta.hs	2009-06-18 15:54:37.000000000 +1200
@@ -273,7 +273,7 @@
     conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
     conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
-    conv_cimportspec CWrapper = return "wrapper"
+    conv_cimportspec (CWrapper poolCapacity) = return ("wrapper "++show poolCapacity)
     static = case cis of
                  CFunction (StaticTarget _) -> "static "
                  _ -> ""
--- ghc-6.10.2.orig/compiler/hsSyn/Convert.lhs	2009-03-31 06:13:16.000000000 +1300
+++ ghc-6.10.2/compiler/hsSyn/Convert.lhs	2009-06-18 15:54:37.000000000 +1200
@@ -256,9 +256,9 @@
 
 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 parse_ccall_impent nm s
- = case lex_ccall_impent s of
+ = case lex_ccall_impent s of                               
        Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
-       Just ["wrapper"] -> Just (nilFS, CWrapper)
+       Just ["wrapper"] -> Just (nilFS, CWrapper 32)
        Just ("static":ts) -> parse_ccall_impent_static nm ts
        Just ts -> parse_ccall_impent_static nm ts
        Nothing -> Nothing
--- ghc-6.10.2.orig/compiler/hsSyn/HsDecls.lhs	2009-03-31 06:13:15.000000000 +1300
+++ ghc-6.10.2/compiler/hsSyn/HsDecls.lhs	2009-06-18 15:54:37.000000000 +1200
@@ -858,8 +858,9 @@
 --
 data CImportSpec = CLabel    CLabelString     -- import address of a C label
 		 | CFunction CCallTarget      -- static or dynamic function
-		 | CWrapper		      -- wrapper to expose closures
+		 | CWrapper  Int	      -- wrapper to expose closures
 					      -- (former f.e.d.)
+                                              -- iPhone: With function pool capacity
 
 -- specification of an externally exported entity in dependence on the calling
 -- convention
@@ -899,7 +900,7 @@
 	pprLib lib <> ppr lbl
       pprCEntity _      _   (CFunction (DynamicTarget)) =
         ptext (sLit "dynamic")
-      pprCEntity _      _   (CWrapper) = ptext (sLit "wrapper")
+      pprCEntity _      _   (CWrapper cap) = ptext (sLit $ "wrapper "++show cap)
       --
       pprLib lib | nullFS lib = empty
 		 | otherwise  = char '[' <> ppr lib <> char ']'
--- ghc-6.10.2.orig/compiler/parser/RdrHsSyn.lhs	2009-03-31 06:13:16.000000000 +1300
+++ ghc-6.10.2/compiler/parser/RdrHsSyn.lhs	2009-06-18 15:54:37.000000000 +1200
@@ -72,8 +72,9 @@
 import Outputable
 import FastString
 
-import List		( isSuffixOf, nubBy )
+import List		( isSuffixOf, nubBy, isPrefixOf )
 import Monad		( unless )
+import Data.Maybe       ( fromMaybe )
 
 #include "HsVersions.h"
 \end{code}
@@ -940,12 +941,12 @@
 --
 mkImport :: CallConv 
 	 -> Safety 
-	 -> (Located FastString, Located RdrName, LHsType RdrName) 
+	 -> (Located FastString, Maybe Int, Located RdrName, LHsType RdrName) 
 	 -> P (HsDecl RdrName)
-mkImport (CCall  cconv) safety (entity, v, ty) = do
-  importSpec <- parseCImport entity cconv safety v
+mkImport (CCall  cconv) safety (entity, mPoolSize, v, ty) = do
+  importSpec <- parseCImport entity cconv safety mPoolSize v
   return (ForD (ForeignImport v ty importSpec))
-mkImport (DNCall      ) _      (entity, v, ty) = do
+mkImport (DNCall      ) _      (entity, _, v, ty) = do
   spec <- parseDImport entity
   return $ ForD (ForeignImport v ty (DNImport spec))
 
@@ -955,14 +956,15 @@
 parseCImport :: Located FastString
 	     -> CCallConv 
 	     -> Safety 
+             -> Maybe Int
 	     -> Located RdrName
 	     -> P ForeignImport
-parseCImport (L loc entity) cconv safety v
+parseCImport (L loc entity) cconv safety mPoolSize v
   -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
   | entity == fsLit "dynamic" = 
     return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
   | entity == fsLit "wrapper" =
-    return $ CImport cconv safety nilFS nilFS CWrapper
+    return $ CImport cconv safety nilFS nilFS (CWrapper $ fromMaybe 32 mPoolSize)
   | otherwise		       = parse0 (unpackFS entity)
     where
       -- using the static keyword?
@@ -1046,14 +1048,14 @@
 -- construct a foreign export declaration
 --
 mkExport :: CallConv
-         -> (Located FastString, Located RdrName, LHsType RdrName) 
+         -> (Located FastString, Maybe Int, Located RdrName, LHsType RdrName) 
 	 -> P (HsDecl RdrName)
-mkExport (CCall  cconv) (L _ entity, v, ty) = return $
+mkExport (CCall  cconv) (L _ entity, _, v, ty) = return $
   ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
   where
     entity' | nullFS entity = mkExtName (unLoc v)
 	    | otherwise     = entity
-mkExport DNCall (L _ _, v, _) =
+mkExport DNCall (L _ _, _, v, _) =
   parseError (getLoc v){-TODO: not quite right-}
 	"Foreign export is not yet supported for .NET"
 
--- ghc-6.10.2.orig/compiler/parser/Lexer.x.source	2009-03-31 06:13:16.000000000 +1300
+++ ghc-6.10.2/compiler/parser/Lexer.x.source	2009-06-18 15:54:37.000000000 +1200
@@ -261,6 +261,7 @@
   					{ token ITgenerated_prag }
   "{-#" $whitechar* (CORE|core)		{ token ITcore_prag }
   "{-#" $whitechar* (UNPACK|unpack)	{ token ITunpack_prag }
+  "{-#" $whitechar* (POOLSIZE|poolsize) { token ITpoolsize_prag }
 
   -- We ignore all these pragmas, but don't generate a warning for them
   -- CFILES is a hugs-only thing.
@@ -495,6 +496,7 @@
   | IToptions_prag String
   | ITinclude_prag String
   | ITlanguage_prag
+  | ITpoolsize_prag
 
   | ITdotdot  			-- reserved symbols
   | ITcolon
--- ghc-6.10.2.orig/compiler/parser/Parser.y.pp.source	2009-03-31 06:13:15.000000000 +1300
+++ ghc-6.10.2/compiler/parser/Parser.y.pp.source	2009-06-18 15:54:37.000000000 +1200
@@ -265,6 +265,7 @@
  '{-# WARNING'  { L _ ITwarning_prag }
  '{-# UNPACK'      { L _ ITunpack_prag }
  '#-}'		   { L _ ITclose_prag }
+ '{-# POOLSIZE'    { L _ ITpoolsize_prag }
 
  '..'		{ L _ ITdotdot }  			-- reserved symbols
  ':'		{ L _ ITcolon }
@@ -949,13 +950,17 @@
 	| 'safe'			{ PlaySafe  False }
 	| 'threadsafe'			{ PlaySafe  True }
 
-fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
-       : STRING var '::' sigtypedoc     { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
-       |        var '::' sigtypedoc     { LL (noLoc nilFS, $1, $3) }
+fspec :: { Located (Located FastString, Maybe Int, Located RdrName, LHsType RdrName) }
+       : STRING poolsize var '::' sigtypedoc     { LL (L (getLoc $1) (getSTRING $1), $2, $3, $5) }
+       |        poolsize var '::' sigtypedoc     { sL (comb2 $2 $>) (noLoc nilFS, $1, $2, $4) }
          -- if the entity string is missing, it defaults to the empty string;
          -- the meaning of an empty entity string depends on the calling
          -- convention
 
+poolsize :: { Maybe Int }
+          : '{-# POOLSIZE' INTEGER '#-}' { Just (fromInteger $ getINTEGER $2) }
+          | {- empty -}                  { Nothing }
+
 -----------------------------------------------------------------------------
 -- Type signatures
 
--- ghc-6.10.2.orig/compiler/typecheck/TcForeign.lhs	2009-03-31 06:13:16.000000000 +1300
+++ ghc-6.10.2/compiler/typecheck/TcForeign.lhs	2009-06-18 15:54:37.000000000 +1200
@@ -116,7 +116,7 @@
        ; return idecl }	     -- NB check res_ty not sig_ty!
        	 	      	     --    In case sig_ty is (forall a. ForeignPtr a)
 
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ (CWrapper _)) = do
    	-- Foreign wrapper (former f.e.d.)
    	-- The type must be of the form ft -> IO (FunPtr ft), where ft is a
    	-- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well

