Implemented and fixed bugs in CmmInfo handling

[ghc-hetmet.git] / utils / genapply / GenApply.hs

diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs
index cdde66f..b7cc6dd 100644 (file)
--- a/utils/genapply/GenApply.hs
+++ b/utils/genapply/GenApply.hs
@@ -6,7 +6,6 @@ module Main(main) where
 #include "../../includes/Constants.h"
 
 
-#if __GLASGOW_HASKELL__ >= 504
 import Text.PrettyPrint
 import Data.Word
 import Data.Bits
@@ -14,14 +13,6 @@ import Data.List     ( intersperse )
 import System.Exit
 import System.Environment
 import System.IO
-#else
-import System
-import IO
-import Bits
-import Word
-import Pretty
-import List            ( intersperse )
-#endif
 
 -- -----------------------------------------------------------------------------
 -- Argument kinds (rougly equivalent to PrimRep)
@@ -202,7 +193,7 @@ genMkPAP regstatus macro jump ticker disamb
     smaller_arity arity
         =  text "if (arity == " <> int arity <> text ") {" $$
            nest 4 (vcat [
-            text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
+          --  text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
 
                -- load up regs for the call, if necessary
             load_regs,
@@ -300,7 +291,7 @@ genMkPAP regstatus macro jump ticker disamb
                | otherwise    = loadRegArgs regstatus stk_args_offset args
          in
          nest 4 (vcat [
-           text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
+--         text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
            reg_doc,
            text "Sp_adj(" <> int sp' <> text ");",
            if is_pap 
@@ -326,7 +317,7 @@ genMkPAP regstatus macro jump ticker disamb
                        empty
           in
           nest 4 (vcat [
-               text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
+--             text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
                save_regs,
                text macro <> char '(' <> int n_args <> comma <> 
                                        int all_args_size <>  
@@ -345,6 +336,18 @@ genMkPAP regstatus macro jump ticker disamb
 -- generate an apply function
 
 -- args is a list of 'p', 'n', 'f', 'd' or 'l'
+formalParam :: ArgRep -> Int -> Doc
+formalParam V _ = empty
+formalParam arg n =
+    formalParamType arg <> space <>
+    text "arg" <> int n <> text ", "
+formalParamType arg | isPtr arg = text "\"ptr\"" <> space <> argRep arg
+                    | otherwise = argRep arg
+
+argRep F = text "F_"
+argRep D = text "D_"
+argRep L = text "L_"
+argRep _ = text "W_"
 
 genApply regstatus args =
    let
@@ -354,9 +357,8 @@ genApply regstatus args =
    in
     vcat [
       text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
-        int all_args_size <> text "/*framsize*/," <>
-       int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/, " <>
-        text "RET_SMALL)\n{",
+        text "RET_SMALL, " <> (cat $ zipWith formalParam args [1..]) <>
+        text ")\n{",
       nest 4 (vcat [
        text "W_ info;",
        text "W_ arity;",
@@ -396,7 +398,7 @@ genApply regstatus args =
 --       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 ");",
+--       text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
 
        let do_assert [] _ = []
           do_assert (arg:args) offset
@@ -414,7 +416,7 @@ genApply regstatus args =
 --    if fast == 1:
 --        print "    goto *lbls[info->type];";
 --    else:
-        text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (%INFO_TYPE(%STD_INFO(info))) {",
+        text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {",
        nest 4 (vcat [
 
 --    if fast == 1:
@@ -483,7 +485,7 @@ genApply regstatus args =
         text "     THUNK_STATIC,",
         text "     THUNK_SELECTOR: {",
        nest 4 (vcat [
-          text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
+--          text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
          text "Sp(0) = " <> fun_info_label <> text ";",
          -- CAREFUL! in SMP mode, the info table may already have been
          -- overwritten by an indirection, so we must enter the original
@@ -540,7 +542,7 @@ genApplyFast regstatus args =
         text "W_ info;",
         text "W_ arity;",
         text  "info = %GET_STD_INFO(R1);",
-        text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (%INFO_TYPE(info)) {",
+        text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {",
        nest 4 (vcat [
           text "case FUN,",
           text "     FUN_1_0,",
@@ -732,7 +734,7 @@ genStackFns regstatus args
 
 genStackApplyArray types =
   vcat [
-    text "section \"rodata\" {",
+    text "section \"relrodata\" {",
     text "stg_ap_stack_entries:",
     text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
     vcat (map arr_ent types),
@@ -743,7 +745,7 @@ genStackApplyArray types =
 
 genStackSaveArray types =
   vcat [
-    text "section \"rodata\" {",
+    text "section \"relrodata\" {",
     text "stg_stack_save_entries:",
     text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
     vcat (map arr_ent types),