ghc/compiler/nativeGen/StixMacro.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixMacro ( macroCode, checkCode ) where
   7
   8 #include "HsVersions.h"
   9 #include "nativeGen/NCG.h"
  10
  11 import {-# SOURCE #-} StixPrim ( amodeToStix )
  12
  13 import MachRegs
  14 import AbsCSyn          ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) )
  15 import Constants        ( uF_RET, uF_UPDATEE, uF_SIZE )
  16 import ForeignCall      ( CCallConv(..) )
  17 import MachOp           ( MachOp(..) )
  18 import PrimRep          ( PrimRep(..) )
  19 import Stix
  20 import Panic            ( panic )
  21 import UniqSupply       ( returnUs, thenUs, UniqSM )
  22 import CLabel           ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
  23                           mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel )
  24 \end{code}
  25 --------------------------------------------------------------------------------
  26 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
  27 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
  28 not there.  The @_LOAD_NODE@ version also loads R1 with an appropriate
  29 closure address.
  30
  31 \begin{code}
  32 macroCode
  33     :: CStmtMacro           -- statement macro
  34     -> [StixExpr]           -- args
  35     -> UniqSM StixStmtList
  36 \end{code}
  37
  38 -----------------------------------------------------------------------------
  39 Updating a CAF
  40
  41 @UPD_CAF@ involves changing the info pointer of the closure, and
  42 adding an indirection.
  43
  44 \begin{code}
  45 macroCode UPD_CAF [cafptr,bhptr]
  46   = let
  47         new_caf = StVoidable (StCall (Left FSLIT("newCAF")) CCallConv VoidRep [cafptr])
  48         a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
  49         a2 = StAssignMem PtrRep cafptr ind_static_info
  50     in
  51     returnUs (\xs -> new_caf : a1 : a2 : xs)
  52 \end{code}
  53
  54 -----------------------------------------------------------------------------
  55 Blackholing
  56
  57 We do lazy blackholing: no need to overwrite thunks with blackholes
  58 the minute they're entered, as long as we do it before a context
  59 switch or garbage collection, that's ok.
  60
  61 Don't blackhole single entry closures, for the following reasons:
  62
  63         - if the compiler has decided that they won't be entered again,
  64           that probably means that nothing has a pointer to it
  65           (not necessarily true, but...)
  66
  67         - no need to blackhole for concurrency reasons, because nothing
  68           can block on the result of this computation.
  69
  70 \begin{code}
  71 macroCode UPD_BH_UPDATABLE args = returnUs id
  72
  73 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
  74 {-
  75   = let
  76         update = StAssign PtrRep (StInd PtrRep arg) bh_info
  77     in
  78     returnUs (\xs -> update : xs)
  79 -}
  80 \end{code}
  81
  82 -----------------------------------------------------------------------------
  83 Update frames
  84
  85 Push an update frame on the stack.
  86
  87 \begin{code}
  88 macroCode PUSH_UPD_FRAME [bhptr, _{-0-}]
  89   = let
  90         frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE)))
  91
  92         -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
  93         a1 = StAssignMem PtrRep (frame uF_RET)     upd_frame_info
  94         a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
  95     in
  96     returnUs (\xs -> a1 : a4 : xs)
  97 \end{code}
  98
  99 -----------------------------------------------------------------------------
 100 Setting the tag register
 101
 102 This one only applies if we have a machine register devoted to TagReg.
 103
 104 \begin{code}
 105 macroCode SET_TAG [tag]
 106   = case get_MagicId_reg_or_addr tagreg of
 107        Right baseRegAddr
 108           -> returnUs id
 109        Left  realreg
 110           -> let a1 = StAssignReg IntRep (StixMagicId tagreg) tag
 111              in returnUs ( \xs -> a1 : xs )
 112 \end{code}
 113
 114 -----------------------------------------------------------------------------
 115
 116 \begin{code}
 117 macroCode REGISTER_IMPORT [arg]
 118    = returnUs (
 119         \xs -> StAssignMem WordRep (StReg stgSp) arg
 120              : StAssignReg PtrRep  stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4])
 121              : xs
 122      )
 123
 124 macroCode REGISTER_FOREIGN_EXPORT [arg]
 125    = returnUs (
 126         \xs -> StVoidable (
 127                   StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep
 128                          [arg]
 129                )
 130              : xs
 131      )
 132
 133 macroCode other args
 134    = panic "StixMacro.macroCode"
 135 \end{code}
 136
 137 Do the business for a @HEAP_CHK@, having converted the args to Trees
 138 of StixOp.
 139
 140 -----------------------------------------------------------------------------
 141 Let's make sure that these CAFs are lifted out, shall we?
 142
 143 \begin{code}
 144 -- Some common labels
 145
 146 bh_info, ind_static_info :: StixExpr
 147
 148 bh_info         = StCLbl mkBlackHoleInfoTableLabel
 149 ind_static_info = StCLbl mkIndStaticInfoLabel
 150 upd_frame_info  = StCLbl mkUpdInfoLabel
 151
 152 -- Some common call trees
 153 \end{code}
 154
 155 -----------------------------------------------------------------------------
 156 Heap/Stack checks
 157
 158 \begin{code}
 159 checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
 160 checkCode macro args assts
 161   = getUniqLabelNCG             `thenUs` \ ulbl_fail ->
 162     getUniqLabelNCG             `thenUs` \ ulbl_pass ->
 163
 164     let args_stix        = map amodeToStix args
 165         newHp wds        = StIndex PtrRep (StReg stgHp) wds
 166         assign_hp wds    = StAssignReg PtrRep stgHp (newHp wds)
 167         hp_alloc wds     = StAssignReg IntRep stgHpAlloc wds
 168         test_hp          = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
 169         cjmp_hp          = StCondJump ulbl_pass test_hp
 170         newSp wds        = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
 171         test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
 172         test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
 173         cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
 174         cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
 175         assign_ret r ret = mkStAssign CodePtrRep r ret
 176
 177         fail = StLabel ulbl_fail
 178         join = StLabel ulbl_pass
 179
 180         -- see includes/StgMacros.h for explaination of these magic consts
 181         aLL_NON_PTRS = 0xff
 182
 183         assign_liveness ptr_regs
 184            = StAssignReg WordRep stgR9
 185                          (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs])
 186         assign_reentry reentry
 187            = StAssignReg WordRep stgR10 reentry
 188     in
 189
 190     returnUs (
 191     case macro of
 192         HP_CHK_NP      ->
 193                 let [words] = args_stix
 194                 in  (\xs -> assign_hp words : cjmp_hp :
 195                             assts (hp_alloc words : gc_enter : join : xs))
 196
 197         STK_CHK_NP     ->
 198                 let [words] = args_stix
 199                 in  (\xs -> cjmp_sp_pass words :
 200                             assts (gc_enter : join : xs))
 201
 202         HP_STK_CHK_NP  ->
 203                 let [sp_words,hp_words] = args_stix
 204                 in  (\xs -> cjmp_sp_fail sp_words :
 205                             assign_hp hp_words : cjmp_hp :
 206                             fail :
 207                             assts (hp_alloc hp_words : gc_enter
 208                                    : join : xs))
 209
 210         HP_CHK_FUN       ->
 211                 let [words] = args_stix
 212                 in  (\xs -> assign_hp words : cjmp_hp :
 213                             assts (hp_alloc words : gc_fun : join : xs))
 214
 215         STK_CHK_FUN       ->
 216                 let [words] = args_stix
 217                 in  (\xs -> cjmp_sp_pass words :
 218                             assts (gc_fun : join : xs))
 219
 220         HP_STK_CHK_FUN    ->
 221                 let [sp_words,hp_words] = args_stix
 222                 in  (\xs -> cjmp_sp_fail sp_words :
 223                             assign_hp hp_words : cjmp_hp :
 224                             fail :
 225                             assts (hp_alloc hp_words
 226                                   : gc_fun : join : xs))
 227
 228         HP_CHK_NOREGS  ->
 229                 let [words] = args_stix
 230                 in  (\xs -> assign_hp words : cjmp_hp :
 231                             assts (hp_alloc words : gc_noregs : join : xs))
 232
 233         HP_CHK_UNPT_R1 ->
 234                 let [words] = args_stix
 235                 in  (\xs -> assign_hp words : cjmp_hp :
 236                             assts (hp_alloc words : gc_unpt_r1 : join : xs))
 237
 238         HP_CHK_UNBX_R1 ->
 239                 let [words] = args_stix
 240                 in  (\xs -> assign_hp words : cjmp_hp :
 241                             assts (hp_alloc words : gc_unbx_r1 : join : xs))
 242
 243         HP_CHK_F1      ->
 244                 let [words] = args_stix
 245                 in  (\xs -> assign_hp words : cjmp_hp :
 246                             assts (hp_alloc words : gc_f1 : join : xs))
 247
 248         HP_CHK_D1      ->
 249                 let [words] = args_stix
 250                 in  (\xs -> assign_hp words : cjmp_hp :
 251                             assts (hp_alloc words : gc_d1 : join : xs))
 252
 253         HP_CHK_L1      ->
 254                 let [words] = args_stix
 255                 in  (\xs -> assign_hp words : cjmp_hp :
 256                             assts (hp_alloc words : gc_l1 : join : xs))
 257
 258         HP_CHK_UNBX_TUPLE  ->
 259                 let [words,liveness] = args_stix
 260                 in (\xs -> assign_hp words : cjmp_hp :
 261                            assts (hp_alloc words : assign_liveness liveness :
 262                                   gc_ut : join : xs))
 263     )
 264
 265 -- Various canned heap-check routines
 266
 267 mkStJump_to_GCentry_name :: String -> StixStmt
 268 mkStJump_to_GCentry_name gcname
 269 --   | opt_Static
 270    = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
 271 --   | otherwise -- it's in a different DLL
 272 --   = StJump (StInd PtrRep (StLitLbl True sdoc))
 273
 274 mkStJump_to_RegTable_offw :: Int -> StixStmt
 275 mkStJump_to_RegTable_offw regtable_offw
 276 --   | opt_Static
 277    = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw))
 278 --   | otherwise
 279 --   do something plausible for cross-DLL jump
 280
 281 gc_enter = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
 282 gc_fun   = mkStJump_to_RegTable_offw OFFSET_stgGCFun
 283
 284 gc_noregs          = mkStJump_to_GCentry_name "stg_gc_noregs"
 285 gc_unpt_r1         = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
 286 gc_unbx_r1         = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
 287 gc_f1              = mkStJump_to_GCentry_name "stg_gc_f1"
 288 gc_d1              = mkStJump_to_GCentry_name "stg_gc_d1"
 289 gc_l1              = mkStJump_to_GCentry_name "stg_gc_l1"
 290 gc_ut              = mkStJump_to_GCentry_name "stg_gc_ut"
 291 \end{code}