[project @ 2003-07-24 13:57:20 by simonmar]

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

diff --git a/ghc/utils/genapply/GenApply.hs b/ghc/utils/genapply/GenApply.hs
index d1ef5df..4cc2ad7 100644 (file)
--- a/ghc/utils/genapply/GenApply.hs
+++ b/ghc/utils/genapply/GenApply.hs
@@ -135,13 +135,29 @@ mkBitmap args = foldr f 0 args
 -- -----------------------------------------------------------------------------
 -- Generating the application functions
 
+-- A SUBTLE POINT about stg_ap functions (can't think of a better
+-- place to put this comment --SDM):
+--
+-- The entry convention to an stg_ap_ function is as follows: all the
+-- arguments are on the stack (we might revisit this at some point,
+-- but it doesn't make any difference on x86), and THERE IS AN EXTRA
+-- EMPTY STACK SLOT at the top of the stack.  
+--
+-- Why?  Because in several cases, stg_ap_* will need an extra stack
+-- slot, eg. to push a return address in the THUNK case, and this is a
+-- way of pushing the stack check up into the caller which is probably
+-- doing one anyway.  Allocating the extra stack slot in the caller is
+-- also probably free, because it will be adjusting Sp after pushing
+-- the args anyway (this might not be true of register-rich machines
+-- when we start passing args to stg_ap_* in regs).
+
 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
+genMkPAP macro jump stack_apply is_pap args all_args_size fun_info_label
   =  smaller_arity_cases
   $$ exact_arity_case
   $$ larger_arity_case
@@ -149,6 +165,9 @@ genMkPAP macro jump is_pap args all_args_size fun_info_label
   where
     n_args = length args
 
+    -- offset of args on the stack, see large comment above.
+    arg_sp_offset = 1
+
 -- The SMALLER ARITY cases:
 --     if (arity == 1) {
 --         Sp[0] = Sp[1];
@@ -161,8 +180,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, arg_sp_offset)
+               | otherwise   = loadRegArgs arg_sp_offset these_args
           in
            nest 4 (vcat [
             reg_doc,
@@ -174,7 +193,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 +216,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, arg_sp_offset)
+               | otherwise   = loadRegArgs arg_sp_offset 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
          ])
@@ -310,8 +329,11 @@ genApply args =
 --    else:
        text "case BCO:",
        nest 4 (vcat [
-         text "arity = BCO_ARITY((StgBCO *)R1.p);",
-         text "goto apply_fun;"
+         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:
@@ -326,9 +348,9 @@ genApply args =
         text "case FUN_STATIC:",
        nest 4 (vcat [
          text "arity = itbl_to_fun_itbl(info)->arity;",
-         text "apply_fun:",
          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
         ]),
 
@@ -340,7 +362,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
         ]),
 
@@ -437,7 +460,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