[project @ 2002-11-20 14:09:42 by simonmar]

Snapshot of the Eval/Apply changes, c. 15 Nov 2002.  This snapshot
should be relatively stable, although GHCi and profiling are currently
known to be broken.

8 files changed, 929 insertions, 232 deletions

diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs
deleted file mode 100644
index 7dcae06d48..0000000000
--- a/ghc/compiler/nativeGen/StixInfo.lhs
+++ /dev/null
@@ -1,168 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
-
-\begin{code}
-module StixInfo (
-
-	genCodeInfoTable, genBitmapInfoTable,
-
-	bitmapToIntegers, bitmapIsSmall, livenessIsSmall
-
-    ) where
-
-#include "HsVersions.h"
-#include "../includes/config.h"
-#include "NCG.h"
-
-import AbsCSyn		( AbstractC(..), Liveness(..), C_SRT(..), needsSRT )
-import ClosureInfo	( closurePtrsSize,
-			  closureNonHdrSize, closureSMRep,
-			  infoTableLabelFromCI,
-			  closureSRT, closureSemiTag
-			)
-import PrimRep		( PrimRep(..) )
-import SMRep		( getSMRepClosureTypeInt )
-import Stix		-- all of it
-import UniqSupply	( returnUs, UniqSM )
-import BitSet		( BitSet, intBS )
-import Maybes		( maybeToBool )
-
-import DATA_BITS
-import DATA_WORD
-\end{code}
-
-Generating code for info tables (arrays of data).
-
-\begin{code}
-genCodeInfoTable
-    :: AbstractC
-    -> UniqSM StixStmtList
-
-genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr)
-  = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs)
-
-    where
-	info_lbl  = infoTableLabelFromCI cl_info
-
-	table | needs_srt = srt_label : rest_of_table
-	      | otherwise = rest_of_table
-
-	rest_of_table = 
-		[
-		{- par, prof, debug -} 
-		  StInt (toInteger layout_info)
-		, StInt (toInteger type_info)
-		]
-
-	-- sigh: building up the info table is endian-dependent.
-	-- ToDo: do this using .byte and .word directives.
-	type_info :: Word32
-#ifdef WORDS_BIGENDIAN
-        type_info = (fromIntegral closure_type `shiftL` 16) .|.
-		    (fromIntegral srt_len)
-#else 
-        type_info = (fromIntegral closure_type) .|.
-		    (fromIntegral srt_len `shiftL` 16)
-#endif	     
-	srt	  = closureSRT cl_info	     
-        needs_srt = needsSRT srt
-
-	(srt_label,srt_len)
-           | is_constr
-           = (StInt 0, tag)
-           | otherwise
-	   = case srt of
-		NoC_SRT 	  -> (StInt 0, 0)
-		C_SRT lbl off len -> (StIndex DataPtrRep (StCLbl lbl) (StInt (toInteger off)), len)
-
-        maybe_tag = closureSemiTag cl_info
-        is_constr = maybeToBool maybe_tag
-        (Just tag) = maybe_tag
-
-	layout_info :: Word32
-#ifdef WORDS_BIGENDIAN
-	layout_info = (fromIntegral ptrs `shiftL` 16) .|. fromIntegral nptrs
-#else 
-	layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` 16)
-#endif	     
-
-    	ptrs    = closurePtrsSize cl_info
-	nptrs	= size - ptrs
-
-        size = closureNonHdrSize cl_info
-
-	closure_type = getSMRepClosureTypeInt (closureSMRep cl_info)
-
-
-
-genBitmapInfoTable
-	:: Liveness
-	-> C_SRT
-	-> Int
-	-> Bool			-- must include SRT field (i.e. it's a vector)
-	-> UniqSM StixStmtList
-
-genBitmapInfoTable liveness srt closure_type include_srt
-  = returnUs (\xs -> StData PtrRep table : xs)
-
-  where
-	table = if srt_len == 0 && not include_srt then
-		   rest_of_table
-		else
-		   srt_label : rest_of_table
-
-	rest_of_table = 
-		[
-		{- par, prof, debug -} 
-		  layout_info
-		, StInt (toInteger type_info)
-		]
-
-	layout_info = case liveness of
-		      Liveness lbl mask ->
-			case bitmapToIntegers mask of
-			[ ] -> StInt 0
-			[i] -> StInt i
-			_   -> StCLbl lbl
-
-	type_info :: Word32
-#ifdef WORDS_BIGENDIAN
-        type_info = (fromIntegral closure_type `shiftL` 16) .|.
-		    (fromIntegral srt_len)
-#else 
-        type_info = (fromIntegral closure_type) .|.
-		    (fromIntegral srt_len `shiftL` 16)
-#endif	     
-
-	(srt_label,srt_len) = 
-	     case srt of
-		NoC_SRT -> (StInt 0, 0)
-		C_SRT lbl off len -> 
-			(StIndex DataPtrRep (StCLbl lbl) 
-				(StInt (toInteger off)), len)
-
-bitmapToIntegers :: [BitSet] -> [Integer]
-bitmapToIntegers = bundle . map (toInteger . intBS)
-  where
-#if BYTES_PER_WORD == 4
-    bundle = id
-#else
-    bundle [] = []
-    bundle is = case splitAt (BYTES_PER_WORD/4) is of
-                (these, those) ->
-		    ( foldr1 (\x y -> x + 4294967296 * y)
-			     [x `mod` 4294967296 | x <- these]
-		    : bundle those
-		    )
-#endif
-
-bitmapIsSmall :: [BitSet] -> Bool
-bitmapIsSmall bitmap
-  = case bitmapToIntegers bitmap of
-    _:_:_ -> False
-    _     -> True
-
-livenessIsSmall :: Liveness -> Bool
-livenessIsSmall (Liveness _ mask) = bitmapIsSmall mask
-\end{code}
diff --git a/ghc/includes/StgFun.h b/ghc/includes/StgFun.h
new file mode 100644
index 0000000000..32d955e2ef
--- /dev/null
+++ b/ghc/includes/StgFun.h
@@ -0,0 +1,46 @@
+/* -----------------------------------------------------------------------------
+ * (c) The GHC Team, 2002
+ *
+ * Things for functions.
+ * ---------------------------------------------------------------------------*/
+
+#ifndef STGFUN_H
+#define STGFUN_H
+
+/* generic - function comes with a small bitmap */
+#define ARG_GEN      0   
+
+/* generic - function comes with a large bitmap */
+#define ARG_GEN_BIG  1
+
+/* specialised function types: bitmaps and calling sequences
+ * for these functions are pre-generated (see ghc/utils/genapply), and
+ * the generated code in ghc/rts/AutoApply.hc.
+ */
+#define ARG_N        2
+#define ARG_P        3
+#define ARG_F        4
+#define ARG_D        5
+#define ARG_L        6
+#define ARG_NN       7
+#define ARG_NP       8
+#define ARG_PN       9
+#define ARG_PP       10
+#define ARG_FF       11
+#define ARG_DD       12
+#define ARG_LL       13
+#define ARG_NNN      14
+#define ARG_NNP      15
+#define ARG_NPN      16
+#define ARG_NPP      17
+#define ARG_PNN      18
+#define ARG_PNP      19
+#define ARG_PPN      20
+#define ARG_PPP      21
+#define ARG_PPPP     22
+#define ARG_PPPPP    23
+#define ARG_PPPPPP   24
+#define ARG_PPPPPPP  25
+#define ARG_PPPPPPPP 26
+
+#endif // STGFUN_H
diff --git a/ghc/rts/Apply.h b/ghc/rts/Apply.h
new file mode 100644
index 0000000000..fe4134181e
--- /dev/null
+++ b/ghc/rts/Apply.h
@@ -0,0 +1,72 @@
+// -----------------------------------------------------------------------------
+// Apply.h
+//
+// (c) The University of Glasgow 2002
+//
+// Helper bits for the generic apply code (AutoApply.hc)
+// -----------------------------------------------------------------------------
+
+#ifndef APPLY_H
+#define APPLY_H
+
+// Build a new PAP: function is in R1,p
+// ret addr and m arguments taking up n words are on the stack.
+#define BUILD_PAP(m,n,f)			\
+ {						\
+    StgPAP *pap;				\
+    nat size, i;				\
+    TICK_SLOW_CALL_BUILT_PAP();			\
+    size = PAP_sizeW(n);			\
+    HP_CHK_NP(size, Sp[0] = f;);		\
+    TICK_ALLOC_PAP(n, 0);			\
+    pap = (StgPAP *) (Hp + 1 - size);		\
+    SET_HDR(pap, &stg_PAP_info, CCCS);		\
+    pap->arity = arity - m;			\
+    pap->fun = R1.cl;				\
+    pap->n_args = n;				\
+    for (i = 0; i < n; i++) {			\
+      pap->payload[i] = (StgClosure *)Sp[1+i];	\
+    }						\
+    R1.p = (P_)pap;				\
+    Sp += 1 + n;				\
+    JMP_(ENTRY_CODE(Sp[0]));			\
+ }
+
+// Copy the old PAP, build a new one with the extra arg(s)
+// ret addr and m arguments taking up n words are on the stack.
+#define NEW_PAP(m,n,f)					\
+ {							\
+     StgPAP *pap, *new_pap;				\
+     nat size, i;					\
+     TICK_SLOW_CALL_NEW_PAP();				\
+     pap = (StgPAP *)R1.p;				\
+     size = PAP_sizeW(pap->n_args + n);			\
+     HP_CHK_NP(size, Sp[0] = f;);			\
+     TICK_ALLOC_PAP(n, 0);				\
+     new_pap = (StgPAP *) (Hp + 1 - size);		\
+     SET_HDR(new_pap, &stg_PAP_info, CCCS);		\
+     new_pap->arity = arity - m;			\
+     new_pap->n_args = pap->n_args + n;			\
+     new_pap->fun = pap->fun;				\
+     for (i = 0; i < pap->n_args; i++) {		\
+	 new_pap->payload[i] = pap->payload[i];		\
+     }							\
+     for (i = 0; i < n; i++) {				\
+        new_pap->payload[pap->n_args+i] = (StgClosure *)Sp[1+i];	\
+     }							\
+     R1.p = (P_)new_pap;				\
+     Sp += n+1;						\
+     JMP_(ENTRY_CODE(Sp[0]));				\
+ }
+
+// canned slow entry points, indexed by arg type (ARG_P, ARG_PP, etc.)
+extern StgFun * stg_ap_stack_entries[];
+
+// canned register save code for heap check failure in a function
+extern StgFun * stg_stack_save_entries[];
+
+// canned bitmap for each arg type
+extern StgWord stg_arg_bitmaps[];
+
+#endif // APPLY_H
+
diff --git a/ghc/rts/Apply.hc b/ghc/rts/Apply.hc
new file mode 100644
index 0000000000..39ca48848c
--- /dev/null
+++ b/ghc/rts/Apply.hc
@@ -0,0 +1,131 @@
+// -----------------------------------------------------------------------------
+// Apply.hc
+//
+// (c) The University of Glasgow 2002
+//
+// Application-related bits.
+//
+// -----------------------------------------------------------------------------
+
+#include "Stg.h"
+#include "Rts.h"
+#include "RtsFlags.h"
+#include "Storage.h"
+#include "RtsUtils.h"
+#include "Printer.h"
+#include "Sanity.h"
+#include "Apply.h"
+
+#include <stdio.h>
+
+// ----------------------------------------------------------------------------
+// Evaluate a closure and return it.
+//
+//      stg_ap_0_info   <--- Sp
+//
+// NOTE: this needs to be a polymorphic return point, because we can't
+// be sure that the thing being evaluated is not a function.
+
+// These names are just to keep VEC_POLY_INFO_TABLE() happy - all the
+// entry points in the polymorphic info table point to the same code.
+#define stg_ap_0_0_ret stg_ap_0_ret
+#define stg_ap_0_1_ret stg_ap_0_ret
+#define stg_ap_0_2_ret stg_ap_0_ret
+#define stg_ap_0_3_ret stg_ap_0_ret
+#define stg_ap_0_4_ret stg_ap_0_ret
+#define stg_ap_0_5_ret stg_ap_0_ret
+#define stg_ap_0_6_ret stg_ap_0_ret
+#define stg_ap_0_7_ret stg_ap_0_ret
+
+VEC_POLY_INFO_TABLE(stg_ap_0,
+	       MK_SMALL_BITMAP(0/*framsize*/, 0/*bitmap*/),
+	       0,0,0,RET_SMALL,,EF_);
+F_
+stg_ap_0_ret(void)
+{ 
+    // fn is in R1, no args on the stack
+    StgInfoTable *info;
+    nat arity;
+    FB_;
+
+    IF_DEBUG(apply,fprintf(stderr, "stg_ap_0_ret... "); printClosure(R1.cl));
+    IF_DEBUG(sanity,checkStackChunk(Sp+1,CurrentTSO->stack + CurrentTSO->stack_size));
+
+    Sp++;
+    ENTER();
+    FE_
+}
+
+/* -----------------------------------------------------------------------------
+   Entry Code for a PAP.
+
+   This entry code is *only* called by one of the stg_ap functions.
+   On entry: Sp points to the remaining arguments on the stack.  If
+   the stack check fails, we can just push the PAP on the stack and
+   return to the scheduler.
+
+   On entry: R1 points to the PAP.  The rest of the function's arguments
+   (*all* of 'em) are on the stack, starting at Sp[0].
+
+   The idea is to copy the chunk of stack from the PAP object onto the
+   stack / into registers, and enter the function.
+   -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_PAP_info,stg_PAP_entry,/*special layout*/0,0,PAP,,EF_,"PAP","PAP");
+STGFUN(stg_PAP_entry)
+{
+  nat Words;
+  StgPtr p;
+  nat i;
+  StgPAP *pap;
+  FB_
+    
+  pap = (StgPAP *) R1.p;
+
+  Words = pap->n_args;
+
+  // Check for stack overflow and bump the stack pointer.
+  // We have a hand-rolled stack check fragment here, because none of
+  // the canned ones suit this situation.
+  if ((Sp - Words) < SpLim) {
+      DEBUG_ONLY(fprintf(stderr,"PAP STACK CHECK!\n"));
+      // there is a return address on the stack in the event of a
+      // stack check failure.  The various stg_apply functions arrange
+      // this before calling stg_PAP_entry.
+      JMP_(stg_gc_unpt_r1);
+  }
+  // Sp is already pointing one word below the arguments...
+  Sp -= Words-1;
+
+  // profiling
+  TICK_ENT_PAP(pap);
+  LDV_ENTER(pap);
+  // Enter PAP cost centre -- lexical scoping only
+  ENTER_CCS_PAP_CL(pap);
+
+  R1.cl = pap->fun;
+  p = (P_)(pap->payload);
+
+  // Reload the stack
+  for (i=0; i<Words; i++) {
+      Sp[i] = (W_) *p++;
+  }
+
+  // Off we go!
+  TICK_ENT_VIA_NODE();
+
+#ifdef NO_ARG_REGS
+  JMP_(GET_ENTRY(R1.cl));
+#else
+  {
+      StgFunInfoTable *info;
+      info = get_fun_itbl(R1.cl);
+      if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
+	  JMP_(info->slow_apply);
+      } else {
+	  JMP_(stg_ap_stack_entries[info->fun_type]);
+      }
+  }
+#endif
+  FE_
+}
diff --git a/ghc/rts/LinkerBasic.c b/ghc/rts/LinkerBasic.c
deleted file mode 100644
index 1c5c40bb3c..0000000000
--- a/ghc/rts/LinkerBasic.c
+++ /dev/null
@@ -1,64 +0,0 @@
-/* -----------------------------------------------------------------------------
- * $Id: LinkerBasic.c,v 1.4 2001/09/04 16:33:04 sewardj Exp $
- *
- * (c) The GHC Team, 2000
- *
- * RTS Object Linker
- *
- * ---------------------------------------------------------------------------*/
-
-#include "PosixSource.h"
-#include "Rts.h"
-#include "Hash.h"
-#include "StoragePriv.h"
-#include "LinkerInternals.h"
-
-/* List of currently loaded objects */
-ObjectCode *objects = NULL;	/* initially empty */
-
-/* -----------------------------------------------------------------------------
- * Look up an address to discover whether it is in text or data space.
- *
- * Used by the garbage collector when walking the stack.
- * -------------------------------------------------------------------------- */
-
-static __inline__ SectionKind
-lookupSection ( void* addr )
-{
-   Section*    se;
-   ObjectCode* oc;
-   
-   for (oc=objects; oc; oc=oc->next) {
-       for (se=oc->sections; se; se=se->next) {
-	   if (se->start <= addr && addr <= se->end)
-	       return se->kind;
-       }
-   }
-   return SECTIONKIND_OTHER;
-}
-
-int
-is_dynamically_loaded_code_or_rodata_ptr ( void* p )
-{
-   SectionKind sk = lookupSection(p);
-   ASSERT (sk != SECTIONKIND_NOINFOAVAIL);
-   return (sk == SECTIONKIND_CODE_OR_RODATA);
-}
-
-
-int
-is_dynamically_loaded_rwdata_ptr ( void* p )
-{
-   SectionKind sk = lookupSection(p);
-   ASSERT (sk != SECTIONKIND_NOINFOAVAIL);
-   return (sk == SECTIONKIND_RWDATA);
-}
-
-
-int
-is_not_dynamically_loaded_ptr ( void* p )
-{
-   SectionKind sk = lookupSection(p);
-   ASSERT (sk != SECTIONKIND_NOINFOAVAIL);
-   return (sk == SECTIONKIND_OTHER);
-}
diff --git a/ghc/rts/Rts.h b/ghc/rts/Rts.h
new file mode 100644
index 0000000000..e209a45783
--- /dev/null
+++ b/ghc/rts/Rts.h
@@ -0,0 +1,112 @@
+/* -----------------------------------------------------------------------------
+ * $Id$
+ *
+ * (c) The GHC Team, 1998-1999
+ *
+ * Top-level include file for the RTS itself
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef RTS_H
+#define RTS_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifndef IN_STG_CODE
+#define IN_STG_CODE 0
+#endif
+#include "Stg.h"
+
+/* -----------------------------------------------------------------------------
+   RTS Exit codes
+   -------------------------------------------------------------------------- */
+
+/* 255 is allegedly used by dynamic linkers to report linking failure */
+#define EXIT_INTERNAL_ERROR 254
+#define EXIT_DEADLOCK       253
+#define EXIT_INTERRUPTED    252
+#define EXIT_HEAPOVERFLOW   251
+#define EXIT_KILLED         250
+
+/* -----------------------------------------------------------------------------
+   Miscellaneous garbage
+   -------------------------------------------------------------------------- */
+
+/* declarations for runtime flags/values */
+#define MAX_RTS_ARGS 32
+
+#ifdef _WIN32
+/* On the yucky side..suppress -Wmissing-declarations warnings when
+ * including <windows.h>
+ */
+extern void* GetCurrentFiber ( void );
+extern void* GetFiberData ( void );
+#endif
+
+/* -----------------------------------------------------------------------------
+   Assertions and Debuggery
+   -------------------------------------------------------------------------- */
+
+#define IF_RTSFLAGS(c,s)  if (RtsFlags.c) { s; }
+
+/* -----------------------------------------------------------------------------
+   Assertions and Debuggery
+   -------------------------------------------------------------------------- */
+
+#ifdef DEBUG
+#define IF_DEBUG(c,s)  if (RtsFlags.DebugFlags.c) { s; }
+#else
+#define IF_DEBUG(c,s)  doNothing()
+#endif
+
+#ifdef DEBUG
+#define DEBUG_ONLY(s) s
+#else
+#define DEBUG_ONLY(s) doNothing()
+#endif
+
+#if defined(GRAN) && defined(DEBUG)
+#define IF_GRAN_DEBUG(c,s)  if (RtsFlags.GranFlags.Debug.c) { s; }
+#else
+#define IF_GRAN_DEBUG(c,s)  doNothing()
+#endif
+
+#if defined(PAR) && defined(DEBUG)
+#define IF_PAR_DEBUG(c,s)  if (RtsFlags.ParFlags.Debug.c) { s; }
+#else
+#define IF_PAR_DEBUG(c,s)  doNothing()
+#endif
+
+/* -----------------------------------------------------------------------------
+   Attributes
+   -------------------------------------------------------------------------- */
+
+#ifdef __GNUC__     /* Avoid spurious warnings                             */
+#if __GNUC__ >= 2 && __GNUC_MINOR__ >= 7
+#define STG_NORETURN  __attribute__ ((noreturn))
+#define STG_UNUSED    __attribute__ ((unused))
+#else
+#define STG_NORETURN  
+#define STG_UNUSED
+#endif
+#else
+#define STG_NORETURN  
+#define STG_UNUSED
+#endif
+
+/* -----------------------------------------------------------------------------
+   Useful macros and inline functions
+   -------------------------------------------------------------------------- */
+
+#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; })
+#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; })
+
+/* -------------------------------------------------------------------------- */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* RTS_H */
diff --git a/ghc/utils/genapply/GenApply.hs b/ghc/utils/genapply/GenApply.hs
new file mode 100644
index 0000000000..b612a0b254
--- /dev/null
+++ b/ghc/utils/genapply/GenApply.hs
@@ -0,0 +1,555 @@
+{-# OPTIONS -cpp #-}
+module Main(main) where
+
+#include "config.h"
+#include "MachRegs.h"
+
+#if __GLASGOW_HASKELL__ >= 504
+import Text.PrettyPrint
+import Data.Word
+import Data.Bits
+import Data.List	( intersperse )
+import Data.Char	( toUpper )
+#else
+import Bits
+import Word
+import Pretty
+import List		( intersperse )
+import Char		( toUpper )
+#endif
+
+
+-- -----------------------------------------------------------------------------
+-- Argument kinds (rougly equivalent to PrimRep)
+
+data ArgRep 
+  = N		-- non-ptr
+  | P		-- ptr
+  | V		-- void
+  | F		-- float
+  | D		-- double
+  | L		-- long (64-bit)
+
+-- size of a value in *words*
+argSize :: ArgRep -> Int
+argSize N = 1
+argSize P = 1
+argSize V = 0
+argSize F = 1
+argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
+argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
+
+showArg :: ArgRep -> Char
+showArg N = 'n'
+showArg P = 'p'
+showArg V = 'v'
+showArg F = 'f'
+showArg D = 'd'
+showArg L = 'l'
+
+-- is a value a pointer?
+isPtr :: ArgRep -> Bool
+isPtr P = True
+isPtr _ = False
+
+-- -----------------------------------------------------------------------------
+-- Registers
+
+type Reg = String
+
+availableRegs :: ([Reg],[Reg],[Reg],[Reg])
+availableRegs = 
+  ( vanillaRegs MAX_REAL_VANILLA_REG,
+    floatRegs   MAX_REAL_FLOAT_REG,
+    doubleRegs  MAX_REAL_DOUBLE_REG,
+    longRegs    MAX_REAL_LONG_REG
+  )
+
+vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
+vanillaRegs n = [ "R" ++ show m ++ ".w" | m <- [2..n] ]  -- never use R1
+floatRegs   n = [ "F" ++ show m | m <- [1..n] ]
+doubleRegs  n = [ "D" ++ show m | m <- [1..n] ]
+longRegs    n = [ "L" ++ show m | m <- [1..n] ]
+
+-- -----------------------------------------------------------------------------
+-- Loading/saving register arguments to the stack
+
+loadRegArgs :: Int -> [ArgRep] -> (Doc,Int)
+loadRegArgs sp args = (vcat (map (uncurry assign_stk_to_reg) reg_locs), sp')
+ where
+  (reg_locs, sp') = assignRegs sp args
+
+-- a bit like assignRegs in CgRetConv.lhs
+assignRegs
+	:: Int			-- Sp of first arg
+	-> [ArgRep]		-- args
+	-> ([(Reg,Int)], Int)	-- Sp and rest of args
+assignRegs sp args = assign sp args availableRegs []
+
+assign sp [] regs doc = (doc, sp)
+assign sp (V : args) regs doc = assign sp args regs doc
+assign sp (arg : args) regs doc
+ = case findAvailableReg arg regs of
+    Just (reg, regs') -> assign (sp + argSize arg)  args regs' 
+	    		    ((reg, sp) : doc)
+    Nothing -> (doc, sp)
+
+findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
+  Just (vreg, (vregs,fregs,dregs,lregs))
+findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
+  Just (vreg, (vregs,fregs,dregs,lregs))
+findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
+  Just (freg, (vregs,fregs,dregs,lregs))
+findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
+  Just (dreg, (vregs,fregs,dregs,lregs))
+findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
+  Just (lreg, (vregs,fregs,dregs,lregs))
+findAvailableReg _ _ = Nothing
+
+assign_reg_to_stk reg@('F':_) sp
+   = text "ASSIGN_FLT(Sp+" <> int sp <> comma <> text reg <> text ");"
+assign_reg_to_stk reg@('D':_) sp
+   = text "ASSIGN_DBL(Sp+" <> int sp <> comma <> text reg <> text ");"
+assign_reg_to_stk reg@('L':_) sp
+   = text "ASSIGN_Word64(Sp+" <> int sp <> comma <> text reg <> text ");"
+assign_reg_to_stk reg sp
+   = text "Sp[" <> int sp <> text "] = " <> text reg <> semi
+
+assign_stk_to_reg reg@('F':_) sp
+   = text reg <> text " = "  <> text "PK_FLT(Sp+" <> int sp <> text ");"
+assign_stk_to_reg reg@('D':_) sp
+   = text reg <> text " = "  <> text "PK_DBL(Sp+" <> int sp <> text ");"
+assign_stk_to_reg reg@('L':_) sp
+   = text reg <> text " = "  <> text "PK_Word64(Sp+" <> int sp <> text ");"
+assign_stk_to_reg reg sp
+   = text reg <> text " = Sp[" <> int sp <> text "];"
+
+
+-- make a ptr/non-ptr bitmap from a list of argument types
+mkBitmap :: [ArgRep] -> Word32
+mkBitmap args = foldr f 0 args
+ where f arg bm | isPtr arg = bm `shiftL` 1
+		| otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
+	        where size = argSize arg
+
+-- -----------------------------------------------------------------------------
+-- Generating the application functions
+
+mkApplyRetName args
+  = text "stg_ap_" <> text (map showArg args) <> text "_ret"
+
+mkApplyInfoName args
+  = text "stg_ap_" <> text (map showArg args) <> text "_info"
+
+genMkPAP macro jump is_pap args all_args_size fun_info_label
+  =  smaller_arity_cases
+  $$ exact_arity_case
+  $$ larger_arity_case
+	
+  where
+    n_args = length args
+
+-- The SMALLER ARITY cases:
+--	if (arity == 1) {
+--	    Sp[0] = Sp[1];
+--	    Sp[1] = (W_)&stg_ap_1_info;
+--	    JMP_(GET_ENTRY(R1.cl));
+
+    smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ]
+
+    smaller_arity arity
+        =  text "if (arity == " <> int arity <> text ") {" $$
+	   let
+	     (reg_doc, sp')
+		| is_pap    = (empty, 1)
+		| otherwise = loadRegArgs 1 these_args
+	   in
+           nest 4 (vcat [
+	     reg_doc,
+	     vcat [ shuffle_down j | j <- [sp'..these_args_size] ],
+	     text "Sp[" <> int these_args_size <>  text "] = (W_)&" <>
+                mkApplyInfoName rest_args <> semi,
+	     text "Sp += " <> int (sp' -  1) <> semi,
+		-- for a PAP, we have to arrange that the stack contains a
+		-- return address in the even that stg_PAP_entry fails its
+		-- heap check.  See stg_PAP_entry in Apply.hc for details.
+	     if is_pap 
+		then text "Sp--; Sp[0] = (W_)&" <> mkApplyInfoName these_args <> semi
+		else empty,
+	     text "JMP_" <> parens (text jump) <> semi
+	    ]) $$
+ 	   text "}"
+	where
+		(these_args, rest_args) = splitAt arity args
+	        these_args_size = sum (map argSize these_args)
+		
+		shuffle_down i = 
+		  text "Sp[" <> int (i-1) <> text "] = Sp["
+		     <> int i <> text "];"
+
+-- The EXACT ARITY case
+--
+--	if (arity == 1) {
+--	    Sp++;
+--	    JMP_(GET_ENTRY(R1.cl));
+
+    exact_arity_case 
+	= text "if (arity == " <> int n_args <> text ") {" $$
+	  let
+	     (reg_doc, sp')
+		| is_pap    = (empty, 0)
+		| otherwise = loadRegArgs 1 args
+	  in
+	  nest 4 (vcat [
+	    reg_doc,
+	    text "Sp += " <> int sp' <> semi,
+	    if is_pap 
+		then text "Sp[0] = (W_)&" <> fun_info_label <> semi
+		else empty,
+	    text "JMP_" <> parens (text jump) <> semi
+	  ])
+
+-- The LARGER ARITY cases:
+--
+--	} else /* arity > 1 */ {
+--	    BUILD_PAP(1,0,(W_)&stg_ap_v_info);
+--	}
+
+    larger_arity_case = 
+	   text "} else {" $$
+	   nest 4 (
+		text macro <> char '(' <> int n_args <> comma <> 
+					int all_args_size <>  
+					text ",(W_)&" <> fun_info_label <>
+					text ");"
+	   ) $$
+	   char '}'
+
+-- -----------------------------------------------------------------------------
+-- generate an apply function
+
+-- args is a list of 'p', 'n', 'f', 'd' or 'l'
+
+genApply args =
+   let
+    fun_ret_label  = mkApplyRetName args
+    fun_info_label = mkApplyInfoName args
+    all_args_size  = sum (map argSize args)
+   in
+    vcat [
+      text "INFO_TABLE_RET(" <> fun_info_label <> text "," <>
+	fun_ret_label <> text "," <>
+        text "MK_SMALL_BITMAP(" <> int all_args_size <> text "/*framsize*/," <>
+	int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/), " <>
+        text "0,0,0,RET_SMALL,,EF_,0,0);",
+      text "",
+      text "F_ " <> fun_ret_label <> text "( void )\n{",
+      nest 4 (vcat [
+       text "StgInfoTable *info;",
+       text "nat arity;",
+
+--    if fast == 1:
+--        print "static void *lbls[] ="
+--        print "  { [FUN]             &&fun_lbl,"
+--        print "    [FUN_1_0]         &&fun_lbl,"
+--        print "    [FUN_0_1]	      &&fun_lbl,"
+--        print "    [FUN_2_0]	      &&fun_lbl,"
+--        print "    [FUN_1_1]	      &&fun_lbl,"
+--        print "    [FUN_0_2]	      &&fun_lbl,"
+--        print "    [FUN_STATIC]      &&fun_lbl,"
+--        print "    [PAP]             &&pap_lbl,"
+--        print "    [THUNK]           &&thunk_lbl,"
+--        print "    [THUNK_1_0]	      &&thunk_lbl,"
+--        print "    [THUNK_0_1]	      &&thunk_lbl,"
+--        print "    [THUNK_2_0]	      &&thunk_lbl,"
+--        print "    [THUNK_1_1]	      &&thunk_lbl,"
+--        print "    [THUNK_0_2]	      &&thunk_lbl,"
+--        print "    [THUNK_STATIC]    &&thunk_lbl,"
+--        print "    [THUNK_SELECTOR]  &&thunk_lbl,"
+--        print "    [IND]	      &&ind_lbl,"
+--        print "    [IND_OLDGEN]      &&ind_lbl,"
+--        print "    [IND_STATIC]      &&ind_lbl,"
+--        print "    [IND_PERM]	      &&ind_lbl,"
+--        print "    [IND_OLDGEN_PERM] &&ind_lbl"
+--        print "  };"
+    
+       text "FB_",
+       text "",
+       text "IF_DEBUG(apply,fprintf(stderr, \"" <> fun_ret_label <> 
+	  text "... \"); printClosure(R1.cl));",
+       text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
+	  text ", CurrentTSO->stack + CurrentTSO->stack_size));",
+    
+       text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
+
+       let do_assert [] _ = []
+	   do_assert (arg:args) offset
+		| isPtr arg = this : rest
+		| otherwise = rest
+	        where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp[" 
+				 <> int offset <> text "]));"
+		      rest = do_assert args (offset + argSize arg)
+       in
+       vcat (do_assert args 1),
+	 
+       text  "again:",
+       text  "info = get_itbl(R1.cl);",
+
+--    if fast == 1:
+--        print "    goto *lbls[info->type];";
+--    else:
+        text "switch (info->type) {" $$
+	 nest 4 (vcat [
+
+--    if fast == 1:
+--        print "    fun_lbl:"
+--    else:
+        text "case FUN:",
+        text "case FUN_1_0:",
+        text "case FUN_0_1:",
+        text "case FUN_2_0:",
+        text "case FUN_1_1:",
+        text "case FUN_0_2:",
+        text "case FUN_STATIC:",
+	nest 4 (vcat [
+	  text "arity = itbl_to_fun_itbl(info)->arity;",
+	  text "ASSERT(arity > 0);",
+          genMkPAP "BUILD_PAP" "GET_ENTRY(R1.cl)" False{-not PAP-}
+		args all_args_size fun_info_label
+	 ]),
+
+--    if fast == 1:
+--        print "    pap_lbl:"
+--    else:
+
+	text "case PAP:",
+	nest 4 (vcat [
+ 	  text "arity = ((StgPAP *)R1.p)->arity;",
+	  text "ASSERT(arity > 0);",
+	  genMkPAP "NEW_PAP" "stg_PAP_entry" True{-is PAP-}
+		args all_args_size fun_info_label
+	 ]),
+
+	text "",
+
+--    if fast == 1:
+--        print "    thunk_lbl:"
+--    else:
+        text "case THUNK:",
+        text "case THUNK_1_0:",
+        text "case THUNK_0_1:",
+        text "case THUNK_2_0:",
+        text "case THUNK_1_1:",
+        text "case THUNK_0_2:",
+        text "case THUNK_STATIC:",
+        text "case THUNK_SELECTOR:",
+	nest 4 (vcat [
+	  text "Sp[0] = (W_)&" <> fun_info_label <> text ";",
+	  text "JMP_(GET_ENTRY(R1.cl));",
+	  text ""
+	 ]),
+
+--    if fast == 1:
+--        print "    ind_lbl:"
+--    else:
+        text "case IND:",
+        text "case IND_OLDGEN:",
+        text "case IND_STATIC:",
+        text "case IND_PERM:",
+        text "case IND_OLDGEN_PERM:",
+	nest 4 (vcat [
+	  text "R1.cl = ((StgInd *)R1.p)->indirectee;",
+	  text "goto again;"
+	 ]),
+	text "",
+
+--    if fast == 0:
+
+       text "default:",
+       nest 4 (
+         text "barf(\"" <> fun_ret_label <> text "\");"
+       ),
+       text "}"
+	
+	])
+      ]),
+      text "FE_",
+      text "}"
+    ]
+
+-- -----------------------------------------------------------------------------
+-- Making a stack apply
+
+-- These little functions are like slow entry points.  They provide
+-- the layer between the PAP entry code and the function's fast entry
+-- point: namely they load arguments off the stack into registers (if
+-- available) and jump to the function's entry code.
+--
+-- On entry: R1 points to the function closure
+--	     arguments are on the stack starting at Sp
+--
+-- Invariant: the list of arguments never contains void.  Since we're only
+-- interested in loading arguments off the stack here, we can ignore
+-- void arguments.
+
+mkStackApplyEntryLabel:: [ArgRep] -> Doc
+mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
+
+genStackApply :: [ArgRep] -> Doc
+genStackApply args = 
+  let fn_entry_label = mkStackApplyEntryLabel args in
+  vcat [
+    text "IFN_" <> parens fn_entry_label,
+    text "{",
+    nest 4 (text "FB_" $$ body $$ text "FE_"),
+    text "}"
+   ]
+ where
+   (assign_regs, sp') = loadRegArgs 0 args
+   body = vcat [assign_regs,
+		text "Sp += " <> int sp' <> semi,
+		text "JMP_(GET_ENTRY(R1.cl))"
+		]
+
+-- -----------------------------------------------------------------------------
+-- Stack save entry points.
+--
+-- These code fragments are used to save registers on the stack at a heap
+-- check failure in the entry code for a function.  We also have to save R1
+-- and the return address (stg_gen_ap_info) on the stack.  See stg_fun_gc_gen
+-- in HeapStackCheck.hc for more details.
+
+mkStackSaveEntryLabel :: [ArgRep] -> Doc
+mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
+
+genStackSave :: [ArgRep] -> Doc
+genStackSave args =
+  let fn_entry_label= mkStackSaveEntryLabel args in
+  vcat [
+    text "IFN_" <> parens fn_entry_label,
+    text "{",
+    nest 4 (text "FB_" $$ body $$ text "FE_"),
+    text "}"
+   ]
+ where
+   body = vcat [text "Sp -= " <> int sp_offset <> semi,
+		vcat (map (uncurry assign_reg_to_stk) reg_locs),
+		text "Sp[2] = R1.w;",
+		text "Sp[1] =" <+> int (sp_offset - std_frame_size) <> semi,
+		text "Sp[0] = (W_)&stg_gc_fun_info;",
+		text "JMP_(stg_gc_noregs);"
+		]
+
+   std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
+		      -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
+   (reg_locs, sp_offset) = assignRegs std_frame_size args
+
+-- -----------------------------------------------------------------------------
+-- The prologue...
+
+main = putStr (render the_code)
+  where the_code = vcat [
+		text "// DO NOT EDIT!",
+		text "// Automatically generated by GenApply.hs",
+		text "",
+		text "#include \"Stg.h\"",
+		text "#include \"Rts.h\"",
+		text "#include \"RtsFlags.h\"",
+		text "#include \"Storage.h\"",
+		text "#include \"RtsUtils.h\"",
+		text "#include \"Printer.h\"",
+		text "#include \"Sanity.h\"",
+		text "#include \"Apply.h\"",
+		text "",
+		text "#include <stdio.h>",
+
+		vcat (intersperse (text "") $ map genApply applyTypes),
+		vcat (intersperse (text "") $ map genStackFns stackApplyTypes),
+
+		genStackApplyArray stackApplyTypes,
+		genStackSaveArray stackApplyTypes,
+		genBitmapArray stackApplyTypes,
+
+		text ""  -- add a newline at the end of the file
+	    ]
+
+-- These have been shown to cover about 99% of cases in practice...
+applyTypes = [
+	[V],
+	[F],
+	[D],
+	[L],
+	[N],
+	[P],
+	[P,V],
+	[P,P],
+	[P,P,V],
+	[P,P,P],
+	[P,P,P,P],
+	[P,P,P,P,P],
+	[P,P,P,P,P,P],
+	[P,P,P,P,P,P,P]
+   ]
+
+-- No need for V args in the stack apply cases.
+-- ToDo: the stack apply and stack save code doesn't make a distinction
+-- between N and P (they both live in the same register), only the bitmap
+-- changes, so we could share the apply/save code between lots of cases.
+stackApplyTypes = [
+	[N],
+	[P],
+	[F],
+	[D],
+	[L],
+	[N,N],
+	[N,P],
+	[P,N],
+	[P,P],
+	[N,N,N],
+	[N,N,P],
+	[N,P,N],
+	[N,P,P],
+	[P,N,N],
+	[P,N,P],
+	[P,P,N],
+	[P,P,P],
+	[P,P,P,P],
+	[P,P,P,P,P],
+	[P,P,P,P,P,P],
+	[P,P,P,P,P,P,P],
+	[P,P,P,P,P,P,P,P]
+   ]
+
+genStackFns args = genStackApply args $$ genStackSave args
+
+
+genStackApplyArray types =
+  text "StgFun *stg_ap_stack_entries[] = {" $$  
+  vcat (map arr_ent types) $$
+  text "};"
+ where
+  arr_ent ty = brackets (arg_const ty) <+> mkStackApplyEntryLabel ty <> comma
+
+genStackSaveArray types =
+  text "StgFun *stg_stack_save_entries[] = {" $$  
+  vcat (map arr_ent types) $$
+  text "};"
+ where
+  arr_ent ty = brackets (arg_const ty) <+> mkStackSaveEntryLabel ty <> comma
+
+genBitmapArray :: [[ArgRep]] -> Doc
+genBitmapArray types =
+  vcat [
+    text "StgWord stg_arg_bitmaps[] = {",
+    vcat (map gen_bitmap types),
+    text "};"
+  ]
+  where
+   gen_bitmap ty = brackets (arg_const ty) <+> 
+		   text "MK_SMALL_BITMAP" <> parens (
+			int (sum (map argSize ty)) <> comma <>
+			text (show (mkBitmap ty))) <>
+		   comma
+
+arg_const ty = text "ARG_" <> text (map toUpper (map showArg ty))
+
diff --git a/ghc/utils/genapply/Makefile b/ghc/utils/genapply/Makefile
new file mode 100644
index 0000000000..c15b745c08
--- /dev/null
+++ b/ghc/utils/genapply/Makefile
@@ -0,0 +1,13 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+
+HS_PROG = $(GHC_GENAPPLY_PGM)
+
+SRC_HC_OPTS += -I$(GHC_INCLUDE_DIR)
+
+# genapply is needed to boot in ghc/rts...
+ifneq "$(BootingFromHc)" "YES"
+boot :: all
+endif
+
+include $(TOP)/mk/target.mk