Remove duplicate functions in StgCmmUtils, use functions from CgUtils
[ghc.git] / compiler / codeGen / StgCmmUtils.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Code generator utilities; mostly monadic
6 --
7 -- (c) The University of Glasgow 2004-2006
8 --
9 -----------------------------------------------------------------------------
10
11 module StgCmmUtils (
12 cgLit, mkSimpleLit,
13 emitDataLits, mkDataLits,
14 emitRODataLits, mkRODataLits,
15 emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
16 assignTemp, newTemp,
17
18 newUnboxedTupleRegs,
19
20 emitMultiAssign, emitCmmLitSwitch, emitSwitch,
21
22 tagToClosure, mkTaggedObjectLoad,
23
24 callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
25
26 cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
27 cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
28 cmmOffsetExprW, cmmOffsetExprB,
29 cmmRegOffW, cmmRegOffB,
30 cmmLabelOffW, cmmLabelOffB,
31 cmmOffsetW, cmmOffsetB,
32 cmmOffsetLitW, cmmOffsetLitB,
33 cmmLoadIndexW,
34 cmmConstrTag1,
35
36 cmmUntag, cmmIsTagged,
37
38 addToMem, addToMemE, addToMemLblE, addToMemLbl,
39 mkWordCLit,
40 newStringCLit, newByteStringCLit,
41 blankWord,
42 ) where
43
44 #include "HsVersions.h"
45
46 import GhcPrelude
47
48 import StgCmmMonad
49 import StgCmmClosure
50 import Cmm
51 import BlockId
52 import MkGraph
53 import CodeGen.Platform
54 import CLabel
55 import CmmUtils
56 import CmmSwitch
57 import CgUtils
58
59 import ForeignCall
60 import IdInfo
61 import Type
62 import TyCon
63 import SMRep
64 import Module
65 import Literal
66 import Digraph
67 import Util
68 import Unique
69 import UniqSupply (MonadUnique(..))
70 import DynFlags
71 import FastString
72 import Outputable
73 import RepType
74
75 import Data.ByteString (ByteString)
76 import qualified Data.ByteString.Char8 as BS8
77 import qualified Data.Map as M
78 import Data.Char
79 import Data.List
80 import Data.Ord
81
82
83 -------------------------------------------------------------------------
84 --
85 -- Literals
86 --
87 -------------------------------------------------------------------------
88
89 cgLit :: Literal -> FCode CmmLit
90 cgLit (LitString s) = newByteStringCLit s
91 -- not unpackFS; we want the UTF-8 byte stream.
92 cgLit other_lit = do dflags <- getDynFlags
93 return (mkSimpleLit dflags other_lit)
94
95 mkSimpleLit :: DynFlags -> Literal -> CmmLit
96 mkSimpleLit dflags (LitChar c) = CmmInt (fromIntegral (ord c))
97 (wordWidth dflags)
98 mkSimpleLit dflags LitNullAddr = zeroCLit dflags
99 mkSimpleLit dflags (LitNumber LitNumInt i _) = CmmInt i (wordWidth dflags)
100 mkSimpleLit _ (LitNumber LitNumInt64 i _) = CmmInt i W64
101 mkSimpleLit dflags (LitNumber LitNumWord i _) = CmmInt i (wordWidth dflags)
102 mkSimpleLit _ (LitNumber LitNumWord64 i _) = CmmInt i W64
103 mkSimpleLit _ (LitFloat r) = CmmFloat r W32
104 mkSimpleLit _ (LitDouble r) = CmmFloat r W64
105 mkSimpleLit _ (LitLabel fs ms fod)
106 = let -- TODO: Literal labels might not actually be in the current package...
107 labelSrc = ForeignLabelInThisPackage
108 in CmmLabel (mkForeignLabel fs ms labelSrc fod)
109 -- NB: LitRubbish should have been lowered in "CoreToStg"
110 mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other)
111
112 --------------------------------------------------------------------------
113 --
114 -- Incrementing a memory location
115 --
116 --------------------------------------------------------------------------
117
118 addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
119 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
120
121 addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
122 addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))
123
124 addToMem :: CmmType -- rep of the counter
125 -> CmmExpr -- Address
126 -> Int -- What to add (a word)
127 -> CmmAGraph
128 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
129
130 addToMemE :: CmmType -- rep of the counter
131 -> CmmExpr -- Address
132 -> CmmExpr -- What to add (a word-typed expression)
133 -> CmmAGraph
134 addToMemE rep ptr n
135 = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
136
137
138 -------------------------------------------------------------------------
139 --
140 -- Loading a field from an object,
141 -- where the object pointer is itself tagged
142 --
143 -------------------------------------------------------------------------
144
145 mkTaggedObjectLoad
146 :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
147 -- (loadTaggedObjectField reg base off tag) generates assignment
148 -- reg = bitsK[ base + off - tag ]
149 -- where K is fixed by 'reg'
150 mkTaggedObjectLoad dflags reg base offset tag
151 = mkAssign (CmmLocal reg)
152 (CmmLoad (cmmOffsetB dflags
153 (CmmReg (CmmLocal base))
154 (offset - tag))
155 (localRegType reg))
156
157 -------------------------------------------------------------------------
158 --
159 -- Converting a closure tag to a closure for enumeration types
160 -- (this is the implementation of tagToEnum#).
161 --
162 -------------------------------------------------------------------------
163
164 tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
165 tagToClosure dflags tycon tag
166 = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)
167 where closure_tbl = CmmLit (CmmLabel lbl)
168 lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
169
170 -------------------------------------------------------------------------
171 --
172 -- Conditionals and rts calls
173 --
174 -------------------------------------------------------------------------
175
176 emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
177 emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
178
179 emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
180 -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
181 emitRtsCallWithResult res hint pkg fun args safe
182 = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
183
184 -- Make a call to an RTS C procedure
185 emitRtsCallGen
186 :: [(LocalReg,ForeignHint)]
187 -> CLabel
188 -> [(CmmExpr,ForeignHint)]
189 -> Bool -- True <=> CmmSafe call
190 -> FCode ()
191 emitRtsCallGen res lbl args safe
192 = do { dflags <- getDynFlags
193 ; updfr_off <- getUpdFrameOff
194 ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
195 ; emit caller_save
196 ; call updfr_off
197 ; emit caller_load }
198 where
199 call updfr_off =
200 if safe then
201 emit =<< mkCmmCall fun_expr res' args' updfr_off
202 else do
203 let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
204 emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
205 (args', arg_hints) = unzip args
206 (res', res_hints) = unzip res
207 fun_expr = mkLblExpr lbl
208
209
210 -----------------------------------------------------------------------------
211 --
212 -- Caller-Save Registers
213 --
214 -----------------------------------------------------------------------------
215
216 -- Here we generate the sequence of saves/restores required around a
217 -- foreign call instruction.
218
219 -- TODO: reconcile with includes/Regs.h
220 -- * Regs.h claims that BaseReg should be saved last and loaded first
221 -- * This might not have been tickled before since BaseReg is callee save
222 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
223 --
224 -- This code isn't actually used right now, because callerSaves
225 -- only ever returns true in the current universe for registers NOT in
226 -- system_regs (just do a grep for CALLER_SAVES in
227 -- includes/stg/MachRegs.h). It's all one giant no-op, and for
228 -- good reason: having to save system registers on every foreign call
229 -- would be very expensive, so we avoid assigning them to those
230 -- registers when we add support for an architecture.
231 --
232 -- Note that the old code generator actually does more work here: it
233 -- also saves other global registers. We can't (nor want) to do that
234 -- here, as we don't have liveness information. And really, we
235 -- shouldn't be doing the workaround at this point in the pipeline, see
236 -- Note [Register parameter passing] and the ToDo on CmmCall in
237 -- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across
238 -- unsafe foreign calls in rewriteAssignments, but this is strictly
239 -- temporary.
240 callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
241 callerSaveVolatileRegs dflags = (caller_save, caller_load)
242 where
243 platform = targetPlatform dflags
244
245 caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)
246 caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
247
248 system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
249 {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
250 , BaseReg ]
251
252 regs_to_save = filter (callerSaves platform) system_regs
253
254 callerSaveGlobalReg reg
255 = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
256
257 callerRestoreGlobalReg reg
258 = mkAssign (CmmGlobal reg)
259 (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
260
261
262 -------------------------------------------------------------------------
263 --
264 -- Strings generate a top-level data block
265 --
266 -------------------------------------------------------------------------
267
268 emitDataLits :: CLabel -> [CmmLit] -> FCode ()
269 -- Emit a data-segment data block
270 emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
271
272 emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
273 -- Emit a read-only data block
274 emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
275
276 newStringCLit :: String -> FCode CmmLit
277 -- Make a global definition for the string,
278 -- and return its label
279 newStringCLit str = newByteStringCLit (BS8.pack str)
280
281 newByteStringCLit :: ByteString -> FCode CmmLit
282 newByteStringCLit bytes
283 = do { uniq <- newUnique
284 ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
285 ; emitDecl decl
286 ; return lit }
287
288 -------------------------------------------------------------------------
289 --
290 -- Assigning expressions to temporaries
291 --
292 -------------------------------------------------------------------------
293
294 assignTemp :: CmmExpr -> FCode LocalReg
295 -- Make sure the argument is in a local register.
296 -- We don't bother being particularly aggressive with avoiding
297 -- unnecessary local registers, since we can rely on a later
298 -- optimization pass to inline as necessary (and skipping out
299 -- on things like global registers can be a little dangerous
300 -- due to them being trashed on foreign calls--though it means
301 -- the optimization pass doesn't have to do as much work)
302 assignTemp (CmmReg (CmmLocal reg)) = return reg
303 assignTemp e = do { dflags <- getDynFlags
304 ; uniq <- newUnique
305 ; let reg = LocalReg uniq (cmmExprType dflags e)
306 ; emitAssign (CmmLocal reg) e
307 ; return reg }
308
309 newTemp :: MonadUnique m => CmmType -> m LocalReg
310 newTemp rep = do { uniq <- getUniqueM
311 ; return (LocalReg uniq rep) }
312
313 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
314 -- Choose suitable local regs to use for the components
315 -- of an unboxed tuple that we are about to return to
316 -- the Sequel. If the Sequel is a join point, using the
317 -- regs it wants will save later assignments.
318 newUnboxedTupleRegs res_ty
319 = ASSERT( isUnboxedTupleType res_ty )
320 do { dflags <- getDynFlags
321 ; sequel <- getSequel
322 ; regs <- choose_regs dflags sequel
323 ; ASSERT( regs `equalLength` reps )
324 return (regs, map primRepForeignHint reps) }
325 where
326 reps = typePrimRep res_ty
327 choose_regs _ (AssignTo regs _) = return regs
328 choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps
329
330
331
332 -------------------------------------------------------------------------
333 -- emitMultiAssign
334 -------------------------------------------------------------------------
335
336 emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
337 -- Emit code to perform the assignments in the
338 -- input simultaneously, using temporary variables when necessary.
339
340 type Key = Int
341 type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
342 -- for fast comparison
343 type Stmt = (LocalReg, CmmExpr) -- r := e
344
345 -- We use the strongly-connected component algorithm, in which
346 -- * the vertices are the statements
347 -- * an edge goes from s1 to s2 iff
348 -- s1 assigns to something s2 uses
349 -- that is, if s1 should *follow* s2 in the final order
350
351 emitMultiAssign [] [] = return ()
352 emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
353 emitMultiAssign regs rhss = do
354 dflags <- getDynFlags
355 ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )
356 unscramble dflags ([1..] `zip` (regs `zip` rhss))
357
358 unscramble :: DynFlags -> [Vrtx] -> FCode ()
359 unscramble dflags vertices = mapM_ do_component components
360 where
361 edges :: [ Node Key Vrtx ]
362 edges = [ DigraphNode vertex key1 (edges_from stmt1)
363 | vertex@(key1, stmt1) <- vertices ]
364
365 edges_from :: Stmt -> [Key]
366 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
367 stmt1 `mustFollow` stmt2 ]
368
369 components :: [SCC Vrtx]
370 components = stronglyConnCompFromEdgedVerticesUniq edges
371
372 -- do_components deal with one strongly-connected component
373 -- Not cyclic, or singleton? Just do it
374 do_component :: SCC Vrtx -> FCode ()
375 do_component (AcyclicSCC (_,stmt)) = mk_graph stmt
376 do_component (CyclicSCC []) = panic "do_component"
377 do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
378
379 -- Cyclic? Then go via temporaries. Pick one to
380 -- break the loop and try again with the rest.
381 do_component (CyclicSCC ((_,first_stmt) : rest)) = do
382 dflags <- getDynFlags
383 u <- newUnique
384 let (to_tmp, from_tmp) = split dflags u first_stmt
385 mk_graph to_tmp
386 unscramble dflags rest
387 mk_graph from_tmp
388
389 split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
390 split dflags uniq (reg, rhs)
391 = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
392 where
393 rep = cmmExprType dflags rhs
394 tmp = LocalReg uniq rep
395
396 mk_graph :: Stmt -> FCode ()
397 mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
398
399 mustFollow :: Stmt -> Stmt -> Bool
400 (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs
401
402 -------------------------------------------------------------------------
403 -- mkSwitch
404 -------------------------------------------------------------------------
405
406
407 emitSwitch :: CmmExpr -- Tag to switch on
408 -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
409 -> Maybe CmmAGraphScoped -- Default branch (if any)
410 -> ConTagZ -> ConTagZ -- Min and Max possible values;
411 -- behaviour outside this range is
412 -- undefined
413 -> FCode ()
414
415 -- First, two rather common cases in which there is no work to do
416 emitSwitch _ [] (Just code) _ _ = emit (fst code)
417 emitSwitch _ [(_,code)] Nothing _ _ = emit (fst code)
418
419 -- Right, off we go
420 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do
421 join_lbl <- newBlockId
422 mb_deflt_lbl <- label_default join_lbl mb_deflt
423 branches_lbls <- label_branches join_lbl branches
424 tag_expr' <- assignTemp' tag_expr
425
426 -- Sort the branches before calling mk_discrete_switch
427 let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]
428 let range = (fromIntegral lo_tag, fromIntegral hi_tag)
429
430 emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range
431
432 emitLabel join_lbl
433
434 mk_discrete_switch :: Bool -- ^ Use signed comparisons
435 -> CmmExpr
436 -> [(Integer, BlockId)]
437 -> Maybe BlockId
438 -> (Integer, Integer)
439 -> CmmAGraph
440
441 -- SINGLETON TAG RANGE: no case analysis to do
442 mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
443 | lo_tag == hi_tag
444 = ASSERT( tag == lo_tag )
445 mkBranch lbl
446
447 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
448 mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _
449 = mkBranch lbl
450 -- The simplifier might have eliminated a case
451 -- so we may have e.g. case xs of
452 -- [] -> e
453 -- In that situation we can be sure the (:) case
454 -- can't happen, so no need to test
455
456 -- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans
457 -- See Note [Cmm Switches, the general plan] in CmmSwitch
458 mk_discrete_switch signed tag_expr branches mb_deflt range
459 = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)
460
461 divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
462 divideBranches branches = (lo_branches, mid, hi_branches)
463 where
464 -- 2 branches => n_branches `div` 2 = 1
465 -- => branches !! 1 give the *second* tag
466 -- There are always at least 2 branches here
467 (mid,_) = branches !! (length branches `div` 2)
468 (lo_branches, hi_branches) = span is_lo branches
469 is_lo (t,_) = t < mid
470
471 --------------
472 emitCmmLitSwitch :: CmmExpr -- Tag to switch on
473 -> [(Literal, CmmAGraphScoped)] -- Tagged branches
474 -> CmmAGraphScoped -- Default branch (always)
475 -> FCode () -- Emit the code
476 emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt
477 emitCmmLitSwitch scrut branches deflt = do
478 scrut' <- assignTemp' scrut
479 join_lbl <- newBlockId
480 deflt_lbl <- label_code join_lbl deflt
481 branches_lbls <- label_branches join_lbl branches
482
483 dflags <- getDynFlags
484 let cmm_ty = cmmExprType dflags scrut
485 rep = typeWidth cmm_ty
486
487 -- We find the necessary type information in the literals in the branches
488 let signed = case head branches of
489 (LitNumber nt _ _, _) -> litNumIsSigned nt
490 _ -> False
491
492 let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
493 | otherwise = (0, tARGET_MAX_WORD dflags)
494
495 if isFloatType cmm_ty
496 then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
497 else emit $ mk_discrete_switch
498 signed
499 scrut'
500 [(litValue lit,l) | (lit,l) <- branches_lbls]
501 (Just deflt_lbl)
502 range
503 emitLabel join_lbl
504
505 -- | lower bound (inclusive), upper bound (exclusive)
506 type LitBound = (Maybe Literal, Maybe Literal)
507
508 noBound :: LitBound
509 noBound = (Nothing, Nothing)
510
511 mk_float_switch :: Width -> CmmExpr -> BlockId
512 -> LitBound
513 -> [(Literal,BlockId)]
514 -> FCode CmmAGraph
515 mk_float_switch rep scrut deflt _bounds [(lit,blk)]
516 = do dflags <- getDynFlags
517 return $ mkCbranch (cond dflags) deflt blk Nothing
518 where
519 cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]
520 where
521 cmm_lit = mkSimpleLit dflags lit
522 ne = MO_F_Ne rep
523
524 mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
525 = do dflags <- getDynFlags
526 lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
527 hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
528 mkCmmIfThenElse (cond dflags) lo_blk hi_blk
529 where
530 (lo_branches, mid_lit, hi_branches) = divideBranches branches
531
532 bounds_lo = (lo_bound, Just mid_lit)
533 bounds_hi = (Just mid_lit, hi_bound)
534
535 cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]
536 where
537 cmm_lit = mkSimpleLit dflags mid_lit
538 lt = MO_F_Lt rep
539
540
541 --------------
542 label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
543 label_default _ Nothing
544 = return Nothing
545 label_default join_lbl (Just code)
546 = do lbl <- label_code join_lbl code
547 return (Just lbl)
548
549 --------------
550 label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
551 label_branches _join_lbl []
552 = return []
553 label_branches join_lbl ((tag,code):branches)
554 = do lbl <- label_code join_lbl code
555 branches' <- label_branches join_lbl branches
556 return ((tag,lbl):branches')
557
558 --------------
559 label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
560 -- label_code J code
561 -- generates
562 -- [L: code; goto J]
563 -- and returns L
564 label_code join_lbl (code,tsc) = do
565 lbl <- newBlockId
566 emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
567 return lbl
568
569 --------------
570 assignTemp' :: CmmExpr -> FCode CmmExpr
571 assignTemp' e
572 | isTrivialCmmExpr e = return e
573 | otherwise = do
574 dflags <- getDynFlags
575 lreg <- newTemp (cmmExprType dflags e)
576 let reg = CmmLocal lreg
577 emitAssign reg e
578 return (CmmReg reg)