X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fgenapply%2FGenApply.hs;h=1cfdf92b7eec7dfe96c179c166efb6cae645caf4;hb=6166618beef243759038fbe3f9c059918f542d9c;hp=b612a0b2543ce2dcac11dedf7c1498aa1dcd47b2;hpb=491f66f835964bbcfa8f7acf46bc2bd1443be679;p=ghc-hetmet.git

diff --git a/ghc/utils/genapply/GenApply.hs b/ghc/utils/genapply/GenApply.hs
index b612a0b..1cfdf92 100644
--- a/ghc/utils/genapply/GenApply.hs
+++ b/ghc/utils/genapply/GenApply.hs
@@ -1,8 +1,8 @@
 {-# OPTIONS -cpp #-}
 module Main(main) where
 
-#include "config.h"
-#include "MachRegs.h"
+#include "../../includes/config.h"
+#include "../../includes/MachRegs.h"
 
 #if __GLASGOW_HASKELL__ >= 504
 import Text.PrettyPrint
@@ -141,7 +141,7 @@ mkApplyRetName args
 mkApplyInfoName args
   = text "stg_ap_" <> text (map showArg args) <> text "_info"
 
-genMkPAP macro jump is_pap args all_args_size fun_info_label
+genMkPAP macro jump stack_apply is_pap args all_args_size fun_info_label
   =  smaller_arity_cases
   $$ exact_arity_case
   $$ larger_arity_case
@@ -161,8 +161,8 @@ genMkPAP macro jump is_pap args all_args_size fun_info_label
         =  text "if (arity == " <> int arity <> text ") {" $$
 	   let
 	     (reg_doc, sp')
-		| is_pap    = (empty, 1)
-		| otherwise = loadRegArgs 1 these_args
+		| stack_apply = (empty, 1)
+		| otherwise   = loadRegArgs 1 these_args
 	   in
            nest 4 (vcat [
 	     reg_doc,
@@ -174,7 +174,7 @@ genMkPAP macro jump is_pap args all_args_size fun_info_label
 		-- 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
+		then text "R2.w = (W_)&" <> mkApplyInfoName these_args <> semi
 		else empty,
 	     text "JMP_" <> parens (text jump) <> semi
 	    ]) $$
@@ -197,14 +197,14 @@ genMkPAP macro jump is_pap args all_args_size fun_info_label
 	= text "if (arity == " <> int n_args <> text ") {" $$
 	  let
 	     (reg_doc, sp')
-		| is_pap    = (empty, 0)
-		| otherwise = loadRegArgs 1 args
+		| stack_apply = (empty, 1)
+		| 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
+		then text "R2.w = (W_)&" <> fun_info_label <> semi
 		else empty,
 	    text "JMP_" <> parens (text jump) <> semi
 	  ])
@@ -277,8 +277,12 @@ genApply args =
        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 "IF_DEBUG(sanity,checkStackFrame(Sp+" <> int (1 + all_args_size)
+	<> text "));",
+
+--       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 ");",
 
@@ -302,6 +306,18 @@ genApply args =
 	 nest 4 (vcat [
 
 --    if fast == 1:
+--        print "    bco_lbl:"
+--    else:
+	text "case BCO:",
+	nest 4 (vcat [
+	  text "arity = ((StgBCO *)R1.p)->arity;",
+	  text "ASSERT(arity > 0);",
+	  genMkPAP "BUILD_PAP" "stg_BCO_entry" 
+		True{-stack apply-} False{-not a PAP-}
+		args all_args_size fun_info_label
+	 ]),
+
+--    if fast == 1:
 --        print "    fun_lbl:"
 --    else:
         text "case FUN:",
@@ -314,7 +330,8 @@ genApply args =
 	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-}
+          genMkPAP "BUILD_PAP" "GET_ENTRY(R1.cl)" 
+		False{-reg apply-} False{-not a PAP-}
 		args all_args_size fun_info_label
 	 ]),
 
@@ -326,7 +343,8 @@ genApply args =
 	nest 4 (vcat [
  	  text "arity = ((StgPAP *)R1.p)->arity;",
 	  text "ASSERT(arity > 0);",
-	  genMkPAP "NEW_PAP" "stg_PAP_entry" True{-is PAP-}
+	  genMkPAP "NEW_PAP" "stg_PAP_entry" 
+		True{-stack apply-} True{-is a PAP-}
 		args all_args_size fun_info_label
 	 ]),
 
@@ -335,6 +353,13 @@ genApply args =
 --    if fast == 1:
 --        print "    thunk_lbl:"
 --    else:
+	text "case AP:",
+	text "case AP_STACK:",
+	text "case CAF_BLACKHOLE:",
+	text "case BLACKHOLE:",
+	text "case BLACKHOLE_BQ:",
+	text "case SE_BLACKHOLE:",
+	text "case SE_CAF_BLACKHOLE:",
         text "case THUNK:",
         text "case THUNK_1_0:",
         text "case THUNK_0_1:",
@@ -399,7 +424,7 @@ genStackApply :: [ArgRep] -> Doc
 genStackApply args = 
   let fn_entry_label = mkStackApplyEntryLabel args in
   vcat [
-    text "IFN_" <> parens fn_entry_label,
+    text "IF_" <> parens fn_entry_label,
     text "{",
     nest 4 (text "FB_" $$ body $$ text "FE_"),
     text "}"
@@ -408,7 +433,7 @@ genStackApply args =
    (assign_regs, sp') = loadRegArgs 0 args
    body = vcat [assign_regs,
 		text "Sp += " <> int sp' <> semi,
-		text "JMP_(GET_ENTRY(R1.cl))"
+		text "JMP_(GET_ENTRY(R1.cl));"
 		]
 
 -- -----------------------------------------------------------------------------
@@ -416,7 +441,7 @@ genStackApply args =
 --
 -- 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
+-- and the return address (stg_gc_fun_info) on the stack.  See stg_gc_fun_gen
 -- in HeapStackCheck.hc for more details.
 
 mkStackSaveEntryLabel :: [ArgRep] -> Doc
@@ -426,7 +451,7 @@ genStackSave :: [ArgRep] -> Doc
 genStackSave args =
   let fn_entry_label= mkStackSaveEntryLabel args in
   vcat [
-    text "IFN_" <> parens fn_entry_label,
+    text "IF_" <> parens fn_entry_label,
     text "{",
     nest 4 (text "FB_" $$ body $$ text "FE_"),
     text "}"