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_SU, 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, mkSeqInfoLabel,
  24                           mkRtsGCEntryLabel )
  25 \end{code}
  26
  27 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
  28 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
  29 not there.  The @_LOAD_NODE@ version also loads R1 with an appropriate
  30 closure address.
  31
  32 \begin{code}
  33 macroCode
  34     :: CStmtMacro           -- statement macro
  35     -> [CAddrMode]          -- args
  36     -> UniqSM StixStmtList
  37 \end{code}
  38
  39 -----------------------------------------------------------------------------
  40 Argument satisfaction checks.
  41
  42 \begin{code}
  43 macroCode ARGS_CHK_LOAD_NODE args
  44   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  45     let
  46           [words, lbl] = map amodeToStix args
  47           temp = StIndex PtrRep (StReg stgSp) words
  48           test = StMachOp MO_NatU_Ge [StReg stgSu, temp]
  49           cjmp = StCondJump ulbl test
  50           assign = StAssignReg PtrRep stgNode lbl
  51           join = StLabel ulbl
  52     in
  53     returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
  54
  55 macroCode ARGS_CHK [words]
  56   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  57     let temp = StIndex PtrRep (StReg stgSp) (amodeToStix words)
  58         test = StMachOp MO_NatU_Ge [StReg stgSu, temp]
  59         cjmp = StCondJump ulbl test
  60         join = StLabel ulbl
  61     in
  62     returnUs (\xs -> cjmp : updatePAP : join : xs)
  63 \end{code}
  64
  65 -----------------------------------------------------------------------------
  66 Updating a CAF
  67
  68 @UPD_CAF@ involves changing the info pointer of the closure, and
  69 adding an indirection.
  70
  71 \begin{code}
  72 macroCode UPD_CAF args
  73   = let
  74         [cafptr,bhptr] = map amodeToStix args
  75         new_caf = StVoidable (StCall (Left SLIT("newCAF")) CCallConv VoidRep [cafptr])
  76         a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
  77         a2 = StAssignMem PtrRep cafptr ind_static_info
  78     in
  79     returnUs (\xs -> new_caf : a1 : a2 : xs)
  80 \end{code}
  81
  82 -----------------------------------------------------------------------------
  83 Blackholing
  84
  85 We do lazy blackholing: no need to overwrite thunks with blackholes
  86 the minute they're entered, as long as we do it before a context
  87 switch or garbage collection, that's ok.
  88
  89 Don't blackhole single entry closures, for the following reasons:
  90
  91         - if the compiler has decided that they won't be entered again,
  92           that probably means that nothing has a pointer to it
  93           (not necessarily true, but...)
  94
  95         - no need to blackhole for concurrency reasons, because nothing
  96           can block on the result of this computation.
  97
  98 \begin{code}
  99 macroCode UPD_BH_UPDATABLE args = returnUs id
 100
 101 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
 102 {-
 103   = let
 104         update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
 105     in
 106     returnUs (\xs -> update : xs)
 107 -}
 108 \end{code}
 109
 110 -----------------------------------------------------------------------------
 111 Update frames
 112
 113 Push a four word update frame on the stack and slide the Su registers
 114 to the current Sp location.
 115
 116 \begin{code}
 117 macroCode PUSH_UPD_FRAME args
 118   = let
 119         [bhptr, _{-0-}] = map amodeToStix args
 120         frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE)))
 121
 122         -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
 123         a1 = StAssignMem PtrRep (frame uF_RET)     upd_frame_info
 124         a3 = StAssignMem PtrRep (frame uF_SU)      (StReg stgSu)
 125         a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
 126
 127         updSu = StAssignReg
 128                    PtrRep
 129                    stgSu
 130                    (StIndex PtrRep (StReg stgSp) (StInt (toInteger (-uF_SIZE))))
 131     in
 132     returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
 133
 134
 135 macroCode PUSH_SEQ_FRAME args
 136    = let [arg_frame] = map amodeToStix args
 137          frame n = StIndex PtrRep arg_frame (StInt (toInteger n))
 138          a1 = StAssignMem PtrRep (frame 0) seq_frame_info
 139          a2 = StAssignMem PtrRep (frame 1) (StReg stgSu)
 140          updSu = StAssignReg PtrRep stgSu arg_frame
 141      in
 142      returnUs (\xs -> a1 : a2 : updSu : xs)
 143
 144
 145 macroCode UPDATE_SU_FROM_UPD_FRAME args
 146    = let [arg_frame] = map amodeToStix args
 147          frame n = StIndex PtrRep arg_frame (StInt (toInteger n))
 148          updSu = StAssignReg PtrRep stgSu (StInd PtrRep (frame uF_SU))
 149      in
 150      returnUs (\xs -> updSu : xs)
 151 \end{code}
 152
 153 -----------------------------------------------------------------------------
 154 Setting the tag register
 155
 156 This one only applies if we have a machine register devoted to TagReg.
 157
 158 \begin{code}
 159 macroCode SET_TAG [tag]
 160   = case get_MagicId_reg_or_addr tagreg of
 161        Right baseRegAddr
 162           -> returnUs id
 163        Left  realreg
 164           -> let a1 = StAssignReg IntRep (StixMagicId tagreg) (amodeToStix tag)
 165              in returnUs ( \xs -> a1 : xs )
 166 \end{code}
 167
 168 -----------------------------------------------------------------------------
 169
 170 \begin{code}
 171 macroCode REGISTER_IMPORT [arg]
 172    = returnUs (
 173         \xs -> StAssignMem WordRep (StReg stgSp) (amodeToStix arg)
 174              : StAssignReg PtrRep  stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4])
 175              : xs
 176      )
 177
 178 macroCode REGISTER_FOREIGN_EXPORT [arg]
 179    = returnUs (
 180         \xs -> StVoidable (
 181                   StCall (Left SLIT("getStablePtr")) CCallConv VoidRep
 182                          [amodeToStix arg]
 183                )
 184              : xs
 185      )
 186
 187 macroCode other args
 188    = panic "StixMacro.macroCode"
 189 \end{code}
 190
 191 Do the business for a @HEAP_CHK@, having converted the args to Trees
 192 of StixOp.
 193
 194 -----------------------------------------------------------------------------
 195 Let's make sure that these CAFs are lifted out, shall we?
 196
 197 \begin{code}
 198 -- Some common labels
 199
 200 bh_info, ind_static_info, ind_info :: StixExpr
 201
 202 bh_info         = StCLbl mkBlackHoleInfoTableLabel
 203 ind_static_info = StCLbl mkIndStaticInfoLabel
 204 ind_info        = StCLbl mkIndInfoLabel
 205 upd_frame_info  = StCLbl mkUpdInfoLabel
 206 seq_frame_info  = StCLbl mkSeqInfoLabel
 207
 208 -- Some common call trees
 209
 210 updatePAP :: StixStmt
 211 updatePAP = mkStJump_to_RegTable_offw OFFSET_stgUpdatePAP
 212
 213 \end{code}
 214
 215 -----------------------------------------------------------------------------
 216 Heap/Stack checks
 217
 218 \begin{code}
 219 checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
 220 checkCode macro args assts
 221   = getUniqLabelNCG             `thenUs` \ ulbl_fail ->
 222     getUniqLabelNCG             `thenUs` \ ulbl_pass ->
 223
 224     let args_stix        = map amodeToStix args
 225         newHp wds        = StIndex PtrRep (StReg stgHp) wds
 226         assign_hp wds    = StAssignReg PtrRep stgHp (newHp wds)
 227         hp_alloc wds     = StAssignReg IntRep stgHpAlloc wds
 228         test_hp          = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
 229         cjmp_hp          = StCondJump ulbl_pass test_hp
 230         newSp wds        = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
 231         test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
 232         test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
 233         cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
 234         cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
 235         assign_ret r ret = mkStAssign CodePtrRep r ret
 236
 237         fail = StLabel ulbl_fail
 238         join = StLabel ulbl_pass
 239
 240         -- see includes/StgMacros.h for explaination of these magic consts
 241         aLL_NON_PTRS
 242            = IF_ARCH_alpha(16383,65535)
 243
 244         assign_liveness ptr_regs
 245            = StAssignReg WordRep stgR9
 246                          (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs])
 247         assign_reentry reentry
 248            = StAssignReg WordRep stgR10 reentry
 249     in
 250
 251     returnUs (
 252     case macro of
 253         HP_CHK_NP      ->
 254                 let [words,ptrs] = args_stix
 255                 in  (\xs -> assign_hp words : cjmp_hp :
 256                             assts (hp_alloc words : gc_enter ptrs : join : xs))
 257
 258         HP_CHK_SEQ_NP  ->
 259                 let [words,ptrs] = args_stix
 260                 in  (\xs -> assign_hp words : cjmp_hp :
 261                             assts (hp_alloc words : gc_seq ptrs : join : xs))
 262
 263         STK_CHK_NP     ->
 264                 let [words,ptrs] = args_stix
 265                 in  (\xs -> cjmp_sp_pass words :
 266                             assts (gc_enter ptrs : join : xs))
 267
 268         HP_STK_CHK_NP  ->
 269                 let [sp_words,hp_words,ptrs] = args_stix
 270                 in  (\xs -> cjmp_sp_fail sp_words :
 271                             assign_hp hp_words : cjmp_hp :
 272                             fail :
 273                             assts (hp_alloc hp_words : gc_enter ptrs
 274                                    : join : xs))
 275
 276         HP_CHK         ->
 277                 let [words,ret,r,ptrs] = args_stix
 278                 in  (\xs -> assign_hp words : cjmp_hp :
 279                             assts (hp_alloc words : assign_ret r ret
 280                                    : gc_chk ptrs : join : xs))
 281
 282         STK_CHK        ->
 283                 let [words,ret,r,ptrs] = args_stix
 284                 in  (\xs -> cjmp_sp_pass words :
 285                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 286
 287         HP_STK_CHK     ->
 288                 let [sp_words,hp_words,ret,r,ptrs] = args_stix
 289                 in  (\xs -> cjmp_sp_fail sp_words :
 290                             assign_hp hp_words : cjmp_hp :
 291                             fail :
 292                             assts (hp_alloc hp_words : assign_ret r ret
 293                                   : gc_chk ptrs : join : xs))
 294
 295         HP_CHK_NOREGS  ->
 296                 let [words] = args_stix
 297                 in  (\xs -> assign_hp words : cjmp_hp :
 298                             assts (hp_alloc words : gc_noregs : join : xs))
 299
 300         HP_CHK_UNPT_R1 ->
 301                 let [words] = args_stix
 302                 in  (\xs -> assign_hp words : cjmp_hp :
 303                             assts (hp_alloc words : gc_unpt_r1 : join : xs))
 304
 305         HP_CHK_UNBX_R1 ->
 306                 let [words] = args_stix
 307                 in  (\xs -> assign_hp words : cjmp_hp :
 308                             assts (hp_alloc words : gc_unbx_r1 : join : xs))
 309
 310         HP_CHK_F1      ->
 311                 let [words] = args_stix
 312                 in  (\xs -> assign_hp words : cjmp_hp :
 313                             assts (hp_alloc words : gc_f1 : join : xs))
 314
 315         HP_CHK_D1      ->
 316                 let [words] = args_stix
 317                 in  (\xs -> assign_hp words : cjmp_hp :
 318                             assts (hp_alloc words : gc_d1 : join : xs))
 319
 320         HP_CHK_L1      ->
 321                 let [words] = args_stix
 322                 in  (\xs -> assign_hp words : cjmp_hp :
 323                             assts (hp_alloc words : gc_l1 : join : xs))
 324
 325         HP_CHK_UT_ALT  ->
 326                 let [words,ptrs,nonptrs,r,ret] = args_stix
 327                 in (\xs -> assign_hp words : cjmp_hp :
 328                            assts (hp_alloc words : assign_ret r ret
 329                                   : gc_ut ptrs nonptrs
 330                                   : join : xs))
 331
 332         HP_CHK_GEN     ->
 333                 let [words,liveness,reentry] = args_stix
 334                 in (\xs -> assign_hp words : cjmp_hp :
 335                            assts (hp_alloc words : assign_liveness liveness :
 336                                   assign_reentry reentry :
 337                                   gc_gen : join : xs))
 338     )
 339
 340 -- Various canned heap-check routines
 341
 342 mkStJump_to_GCentry_name :: String -> StixStmt
 343 mkStJump_to_GCentry_name gcname
 344 --   | opt_Static
 345    = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
 346 --   | otherwise -- it's in a different DLL
 347 --   = StJump (StInd PtrRep (StLitLbl True sdoc))
 348
 349 mkStJump_to_RegTable_offw :: Int -> StixStmt
 350 mkStJump_to_RegTable_offw regtable_offw
 351 --   | opt_Static
 352    = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw))
 353 --   | otherwise
 354 --   do something plausible for cross-DLL jump
 355
 356 gc_chk (StInt 0)   = mkStJump_to_RegTable_offw OFFSET_stgChk0
 357 gc_chk (StInt 1)   = mkStJump_to_RegTable_offw OFFSET_stgChk1
 358 gc_chk (StInt n)   = mkStJump_to_GCentry_name ("stg_chk_" ++ show n)
 359
 360 gc_enter (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
 361 gc_enter (StInt n) = mkStJump_to_GCentry_name ("stg_gc_enter_" ++ show n)
 362
 363 gc_seq (StInt n)   = mkStJump_to_GCentry_name ("stg_gc_seq_" ++ show n)
 364 gc_noregs          = mkStJump_to_GCentry_name "stg_gc_noregs"
 365 gc_unpt_r1         = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
 366 gc_unbx_r1         = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
 367 gc_f1              = mkStJump_to_GCentry_name "stg_gc_f1"
 368 gc_d1              = mkStJump_to_GCentry_name "stg_gc_d1"
 369 gc_l1              = mkStJump_to_GCentry_name "stg_gc_l1"
 370 gc_gen             = mkStJump_to_GCentry_name "stg_gen_chk"
 371 gc_ut (StInt p) (StInt np)
 372                    = mkStJump_to_GCentry_name ("stg_gc_ut_" ++ show p ++ "_" ++ show np)
 373 \end{code}