[project @ 2001-06-15 12:07:03 by simonmar]
[ghc-hetmet.git] / 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,
15                           CCheckMacro(..) )
16 import Constants        ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
17 import ForeignCall      ( CCallConv(..) )
18 import PrimOp           ( PrimOp(..) )
19 import PrimRep          ( PrimRep(..) )
20 import Stix
21 import UniqSupply       ( returnUs, thenUs, UniqSM )
22 import CLabel           ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
23                           mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel,
24                           mkRtsGCEntryLabel, mkStgUpdatePAPLabel )
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 StixTreeList
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 stgSp words
48           test = StPrim AddrGeOp [stgSu, temp]
49           cjmp = StCondJump ulbl test
50           assign = StAssign 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 stgSp (amodeToStix words)
58         test = StPrim AddrGeOp [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 = StCall SLIT("newCAF") CCallConv VoidRep [cafptr]
76         w0 = StInd PtrRep cafptr
77         w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
78         a1 = StAssign PtrRep w1 bhptr
79         a2 = StAssign PtrRep w0 ind_static_info
80     in
81     returnUs (\xs -> new_caf : a1 : a2 : xs)
82 \end{code}
83
84 -----------------------------------------------------------------------------
85 Blackholing
86
87 We do lazy blackholing: no need to overwrite thunks with blackholes
88 the minute they're entered, as long as we do it before a context
89 switch or garbage collection, that's ok.
90
91 Don't blackhole single entry closures, for the following reasons:
92         
93         - if the compiler has decided that they won't be entered again,
94           that probably means that nothing has a pointer to it
95           (not necessarily true, but...)
96
97         - no need to blackhole for concurrency reasons, because nothing
98           can block on the result of this computation.
99
100 \begin{code}
101 macroCode UPD_BH_UPDATABLE args = returnUs id
102
103 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
104 {-
105   = let
106         update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
107     in
108     returnUs (\xs -> update : xs)
109 -}
110 \end{code}
111
112 -----------------------------------------------------------------------------
113 Update frames
114
115 Push a four word update frame on the stack and slide the Su registers
116 to the current Sp location.
117
118 \begin{code}
119 macroCode PUSH_UPD_FRAME args
120   = let
121         [bhptr, _{-0-}] = map amodeToStix args
122         frame n = StInd PtrRep
123             (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
124
125         -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
126         a1 = StAssign PtrRep (frame uF_RET)     upd_frame_info
127         a3 = StAssign PtrRep (frame uF_SU)      stgSu
128         a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
129
130         updSu = StAssign PtrRep stgSu
131                 (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
132     in
133     returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
134
135
136 macroCode PUSH_SEQ_FRAME args
137    = let [arg_frame] = map amodeToStix args
138          frame n = StInd PtrRep
139                      (StIndex PtrRep arg_frame (StInt (toInteger n)))
140          a1 = StAssign PtrRep (frame 0) seq_frame_info
141          a2 = StAssign PtrRep (frame 1) stgSu
142          updSu = StAssign PtrRep stgSu arg_frame 
143      in
144      returnUs (\xs -> a1 : a2 : updSu : xs)
145
146
147 macroCode UPDATE_SU_FROM_UPD_FRAME args
148    = let [arg_frame] = map amodeToStix args
149          frame n = StInd PtrRep
150                       (StIndex PtrRep arg_frame (StInt (toInteger n)))
151          updSu
152             = StAssign PtrRep stgSu (frame uF_SU)
153      in
154      returnUs (\xs -> updSu : xs)
155 \end{code}
156
157 -----------------------------------------------------------------------------
158 Setting the tag register
159
160 This one only applies if we have a machine register devoted to TagReg.
161
162 \begin{code}
163 macroCode SET_TAG [tag]
164   = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
165     in
166     case stgReg tagreg of
167       Always _ -> returnUs id
168       Save   _ -> returnUs (\ xs -> set_tag : xs)
169 \end{code}
170
171 -----------------------------------------------------------------------------
172
173 \begin{code}
174 macroCode REGISTER_IMPORT [arg]
175    = returnUs (
176         \xs -> StAssign WordRep (StInd WordRep stgSp) (amodeToStix arg)
177              : StAssign PtrRep  stgSp (StPrim IntAddOp [stgSp, StInt 4])
178              : xs
179      )
180
181 macroCode REGISTER_FOREIGN_EXPORT [arg]
182    = returnUs (
183         \xs -> StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg]
184              : xs
185      )
186
187 macroCode other args
188    = case other of
189         SET_TAG -> error "foobarxyzzy8"
190         _       -> error "StixMacro.macroCode: unknown macro/args"
191 \end{code}
192
193
194 Do the business for a @HEAP_CHK@, having converted the args to Trees
195 of StixOp.
196
197 -----------------------------------------------------------------------------
198 Let's make sure that these CAFs are lifted out, shall we?
199
200 \begin{code}
201 -- Some common labels
202
203 bh_info, ind_static_info, ind_info :: StixTree
204
205 bh_info         = StCLbl mkBlackHoleInfoTableLabel
206 ind_static_info = StCLbl mkIndStaticInfoLabel
207 ind_info        = StCLbl mkIndInfoLabel
208 upd_frame_info  = StCLbl mkUpdInfoLabel
209 seq_frame_info  = StCLbl mkSeqInfoLabel
210 stg_update_PAP  = StCLbl mkStgUpdatePAPLabel
211 -- Some common call trees
212
213 updatePAP, stackOverflow :: StixTree
214
215 updatePAP     = StJump NoDestInfo stg_update_PAP
216 stackOverflow = StCall SLIT("StackOverflow") CCallConv VoidRep []
217 \end{code}
218
219 -----------------------------------------------------------------------------
220 Heap/Stack checks
221
222 \begin{code}
223 checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
224 checkCode macro args assts
225   = getUniqLabelNCG             `thenUs` \ ulbl_fail ->
226     getUniqLabelNCG             `thenUs` \ ulbl_pass ->
227
228     let args_stix = map amodeToStix args
229         newHp wds = StIndex PtrRep stgHp wds
230         assign_hp wds = StAssign PtrRep stgHp (newHp wds)
231         test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
232         cjmp_hp = StCondJump ulbl_pass test_hp
233
234         newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
235         test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
236         test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
237         cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
238         cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
239
240         assign_ret r ret = StAssign CodePtrRep r ret
241
242         fail = StLabel ulbl_fail
243         join = StLabel ulbl_pass
244
245         -- see includes/StgMacros.h for explaination of these magic consts
246         aLL_NON_PTRS
247            = IF_ARCH_alpha(16383,65535)
248
249         assign_liveness ptr_regs 
250            = StAssign WordRep stgR9
251                       (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs])
252         assign_reentry reentry 
253            = StAssign WordRep stgR10 reentry
254     in  
255
256     returnUs (
257     case macro of
258         HP_CHK_NP      -> 
259                 let [words,ptrs] = args_stix
260                 in  (\xs -> assign_hp words : cjmp_hp : 
261                             assts (gc_enter ptrs : join : xs))
262
263         HP_CHK_SEQ_NP  -> 
264                 let [words,ptrs] = args_stix
265                 in  (\xs -> assign_hp words : cjmp_hp : 
266                             assts (gc_seq ptrs : join : xs))
267
268         STK_CHK_NP     -> 
269                 let [words,ptrs] = args_stix
270                 in  (\xs -> cjmp_sp_pass words :
271                             assts (gc_enter ptrs : join : xs))
272
273         HP_STK_CHK_NP  -> 
274                 let [sp_words,hp_words,ptrs] = args_stix
275                 in  (\xs -> cjmp_sp_fail sp_words : 
276                             assign_hp hp_words : cjmp_hp :
277                             fail :
278                             assts (gc_enter ptrs : join : xs))
279
280         HP_CHK         -> 
281                 let [words,ret,r,ptrs] = args_stix
282                 in  (\xs -> assign_hp words : cjmp_hp :
283                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
284
285         STK_CHK        -> 
286                 let [words,ret,r,ptrs] = args_stix
287                 in  (\xs -> cjmp_sp_pass words :
288                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
289
290         HP_STK_CHK     -> 
291                 let [sp_words,hp_words,ret,r,ptrs] = args_stix
292                 in  (\xs -> cjmp_sp_fail sp_words :
293                             assign_hp hp_words : cjmp_hp :
294                             fail :
295                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
296
297         HP_CHK_NOREGS  -> 
298                 let [words] = args_stix
299                 in  (\xs -> assign_hp words : cjmp_hp : 
300                             assts (gc_noregs : join : xs))
301
302         HP_CHK_UNPT_R1 -> 
303                 let [words] = args_stix
304                 in  (\xs -> assign_hp words : cjmp_hp : 
305                             assts (gc_unpt_r1 : join : xs))
306
307         HP_CHK_UNBX_R1 -> 
308                 let [words] = args_stix
309                 in  (\xs -> assign_hp words : cjmp_hp : 
310                             assts (gc_unbx_r1 : join : xs))
311
312         HP_CHK_F1      -> 
313                 let [words] = args_stix
314                 in  (\xs -> assign_hp words : cjmp_hp : 
315                             assts (gc_f1 : join : xs))
316
317         HP_CHK_D1      -> 
318                 let [words] = args_stix
319                 in  (\xs -> assign_hp words : cjmp_hp : 
320                             assts (gc_d1 : join : xs))
321
322         HP_CHK_UT_ALT  -> 
323                 let [words,ptrs,nonptrs,r,ret] = args_stix
324                 in (\xs -> assign_hp words : cjmp_hp :
325                            assts (assign_ret r ret : gc_ut ptrs nonptrs 
326                                   : join : xs))
327
328         HP_CHK_GEN     -> 
329                 let [words,liveness,reentry] = args_stix
330                 in (\xs -> assign_hp words : cjmp_hp :
331                            assts (assign_liveness liveness :
332                                   assign_reentry reentry :
333                                   gc_gen : join : xs))
334     )
335         
336 -- Various canned heap-check routines
337
338 mkStJump_to_GCentry :: String -> StixTree
339 mkStJump_to_GCentry gcname
340 --   | opt_Static
341    = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
342 --   | otherwise -- it's in a different DLL
343 --   = StJump (StInd PtrRep (StLitLbl True sdoc))
344
345 gc_chk (StInt n)   = mkStJump_to_GCentry ("stg_chk_" ++ show n)
346 gc_enter (StInt n) = mkStJump_to_GCentry ("stg_gc_enter_" ++ show n)
347 gc_seq (StInt n)   = mkStJump_to_GCentry ("stg_gc_seq_" ++ show n)
348 gc_noregs          = mkStJump_to_GCentry "stg_gc_noregs"
349 gc_unpt_r1         = mkStJump_to_GCentry "stg_gc_unpt_r1"
350 gc_unbx_r1         = mkStJump_to_GCentry "stg_gc_unbx_r1"
351 gc_f1              = mkStJump_to_GCentry "stg_gc_f1"
352 gc_d1              = mkStJump_to_GCentry "stg_gc_d1"
353 gc_gen             = mkStJump_to_GCentry "stg_gen_chk"
354 gc_ut (StInt p) (StInt np)
355                    = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p 
356                                           ++ "_" ++ show np)
357 \end{code}