[project @ 2000-02-28 12:02:31 by sewardj]

[ghc-hetmet.git] / ghc / compiler / nativeGen / StixMacro.lhs

diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index 44aead0..4af972d 100644 (file)
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -6,6 +6,7 @@
 module StixMacro ( macroCode, checkCode ) where
 
 #include "HsVersions.h"
+#include "nativeGen/NCG.h"
 
 import {-# SOURCE #-} StixPrim ( amodeToStix )
 
@@ -15,7 +16,6 @@ import AbsCSyn                ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
                          CCheckMacro(..) )
 import Constants       ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE, sEQ_FRAME_SIZE )
 import CallConv                ( cCallConv )
-import OrdList         ( OrdList )
 import PrimOp          ( PrimOp(..) )
 import PrimRep         ( PrimRep(..) )
 import Stix
@@ -136,12 +136,22 @@ macroCode PUSH_UPD_FRAME args
 macroCode PUSH_SEQ_FRAME args
    = let [arg_frame] = map amodeToStix args
          frame n = StInd PtrRep
-            (StIndex PtrRep arg_frame (StInt (toInteger n)))
+                     (StIndex PtrRep arg_frame (StInt (toInteger n)))
          a1 = StAssign PtrRep (frame 0) seq_frame_info
          a2 = StAssign PtrRep (frame 1) stgSu
          updSu = StAssign PtrRep stgSu arg_frame 
      in
      returnUs (\xs -> a1 : a2 : updSu : xs)
+
+
+macroCode UPDATE_SU_FROM_UPD_FRAME args
+   = let [arg_frame] = map amodeToStix args
+         frame n = StInd PtrRep
+                      (StIndex PtrRep arg_frame (StInt (toInteger n)))
+         updSu
+            = StAssign PtrRep stgSu (frame uF_SU)
+     in
+     returnUs (\xs -> updSu : xs)
 \end{code}
 
 -----------------------------------------------------------------------------
@@ -157,6 +167,18 @@ macroCode SET_TAG [tag]
       Always _ -> returnUs id
       Save   _ -> returnUs (\ xs -> set_tag : xs)
 
+macroCode other args
+   = case other of
+        ARGS_CHK -> error "foobarxyzzy1"
+        ARGS_CHK_LOAD_NODE -> error "foobarxyzzy2"
+        UPD_CAF -> error "foobarxyzzy3"
+        UPD_BH_UPDATABLE -> error "foobarxyzzy4"
+        UPD_BH_SINGLE_ENTRY -> error "foobarxyzzy5"
+        PUSH_UPD_FRAME -> error "foobarxyzzy6"
+        PUSH_SEQ_FRAME -> error "foobarxyzzy7"
+        UPDATE_SU_FROM_UPD_FRAME -> error "foobarxyzzy8"
+        SET_TAG -> error "foobarxyzzy9"
+
 \end{code}
 
 
@@ -210,6 +232,16 @@ checkCode macro args assts
 
        fail = StLabel ulbl_fail
        join = StLabel ulbl_pass
+
+        -- see includes/StgMacros.h for explaination of these magic consts
+        aLL_NON_PTRS
+           = IF_ARCH_alpha(16383,65535)
+
+        assign_liveness ptr_regs 
+           = StAssign WordRep stgR9
+                      (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs])
+        assign_reentry reentry 
+           = StAssign WordRep stgR10 reentry
     in 
 
     returnUs (
@@ -219,6 +251,11 @@ checkCode macro args assts
                in  (\xs -> assign_hp words : cjmp_hp : 
                            assts (gc_enter ptrs : join : xs))
 
+       HP_CHK_SEQ_NP  -> 
+               let [words,ptrs] = args_stix
+               in  (\xs -> assign_hp words : cjmp_hp : 
+                           assts (gc_seq ptrs : join : xs))
+
        STK_CHK_NP     -> 
                let [words,ptrs] = args_stix
                in  (\xs -> cjmp_sp_pass words :
@@ -276,23 +313,34 @@ checkCode macro args assts
        HP_CHK_UT_ALT  -> 
                 let [words,ptrs,nonptrs,r,ret] = args_stix
                 in (\xs -> assign_hp words : cjmp_hp :
-                           assts (assign_ret r ret : gc_ut ptrs nonptrs : join : xs))
+                           assts (assign_ret r ret : gc_ut ptrs nonptrs 
+                                  : join : xs))
 
        HP_CHK_GEN     -> 
-               error "unimplemented check"
-  )
+                let [words,liveness,reentry] = args_stix
+                in (\xs -> assign_hp words : cjmp_hp :
+                           assts (assign_liveness liveness :
+                                  assign_reentry reentry :
+                                  gc_gen : join : xs))
+    )
        
 -- Various canned heap-check routines
 
-gc_chk (StInt n)   = StJump (StLitLbl (ptext SLIT("stg_chk_") <> int (fromInteger n)))
-gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") <> int (fromInteger n)))
+gc_chk (StInt n)   = StJump (StLitLbl (ptext SLIT("stg_chk_") 
+                                       <> int (fromInteger n)))
+gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") 
+                                       <> int (fromInteger n)))
+gc_seq (StInt n)   = StJump (StLitLbl (ptext SLIT("stg_gc_seq_") 
+                                       <> int (fromInteger n)))
 gc_noregs          = StJump (StLitLbl (ptext SLIT("stg_gc_noregs")))
 gc_unpt_r1         = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1")))
 gc_unbx_r1         = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1")))
 gc_f1              = StJump (StLitLbl (ptext SLIT("stg_gc_f1")))
 gc_d1              = StJump (StLitLbl (ptext SLIT("stg_gc_d1")))
+gc_gen             = StJump (StLitLbl (ptext SLIT("stg_gen_chk")))
 
 gc_ut (StInt p) (StInt np)
-                   = StJump (StLitLbl (ptext SLIT("stg_gc_ut_") <> int (fromInteger p) 
+                   = StJump (StLitLbl (ptext SLIT("stg_gc_ut_") 
+                                       <> int (fromInteger p) 
                                        <> char '_' <> int (fromInteger np)))
 \end{code}