[project @ 2002-11-21 10:04:20 by simonmar]
authorsimonmar <unknown>
Thu, 21 Nov 2002 10:04:21 +0000 (10:04 +0000)
committersimonmar <unknown>
Thu, 21 Nov 2002 10:04:21 +0000 (10:04 +0000)
Repair the HEAD after some file adds/removes that were supposed to
happen on the eval-apply-branch yesterday mysteriously happened on the
HEAD instead.

ghc/compiler/nativeGen/StixInfo.lhs [new file with mode: 0644]
ghc/rts/LinkerBasic.c [new file with mode: 0644]
ghc/utils/genapply/GenApply.hs [deleted file]
ghc/utils/genapply/Makefile [deleted file]

diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs
new file mode 100644 (file)
index 0000000..7dcae06
--- /dev/null
@@ -0,0 +1,168 @@
+%
+% (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/rts/LinkerBasic.c b/ghc/rts/LinkerBasic.c
new file mode 100644 (file)
index 0000000..2d3e603
--- /dev/null
@@ -0,0 +1,64 @@
+/* -----------------------------------------------------------------------------
+ * $Id: LinkerBasic.c,v 1.6 2002/11/21 10:04:21 simonmar 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/utils/genapply/GenApply.hs b/ghc/utils/genapply/GenApply.hs
deleted file mode 100644 (file)
index b612a0b..0000000
+++ /dev/null
@@ -1,555 +0,0 @@
-{-# 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
deleted file mode 100644 (file)
index c15b745..0000000
+++ /dev/null
@@ -1,13 +0,0 @@
-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