{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
--
-- Code generator utilities; mostly monadic
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module GHC.StgToCmm.Utils (
        cgLit, mkSimpleLit,
        emitDataLits, mkDataLits,
        emitRODataLits, mkRODataLits,
        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
        assignTemp, newTemp,

        newUnboxedTupleRegs,

        emitMultiAssign, emitCmmLitSwitch, emitSwitch,

        tagToClosure, mkTaggedObjectLoad,

        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,

        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
        cmmOffsetExprW, cmmOffsetExprB,
        cmmRegOffW, cmmRegOffB,
        cmmLabelOffW, cmmLabelOffB,
        cmmOffsetW, cmmOffsetB,
        cmmOffsetLitW, cmmOffsetLitB,
        cmmLoadIndexW,
        cmmConstrTag1,

        cmmUntag, cmmIsTagged,

        addToMem, addToMemE, addToMemLblE, addToMemLbl,
        mkWordCLit,
        newStringCLit, newByteStringCLit,
        blankWord,

        -- * Update remembered set operations
        whenUpdRemSetEnabled,
        emitUpdRemSetPush,
        emitUpdRemSetPushThunk,
  ) where

#include "HsVersions.h"

import GhcPrelude

import GHC.StgToCmm.Monad
import GHC.StgToCmm.Closure
import Cmm
import BlockId
import MkGraph
import GHC.Platform.Regs
import CLabel
import CmmUtils
import CmmSwitch
import GHC.StgToCmm.CgUtils

import ForeignCall
import IdInfo
import Type
import TyCon
import SMRep
import Module
import Literal
import Digraph
import Util
import Unique
import UniqSupply (MonadUnique(..))
import DynFlags
import FastString
import Outputable
import RepType

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Map as M
import Data.Char
import Data.List
import Data.Ord


-------------------------------------------------------------------------
--
--      Literals
--
-------------------------------------------------------------------------

cgLit :: Literal -> FCode CmmLit
cgLit :: Literal -> FCode CmmLit
cgLit (LitString ByteString
s) = ByteString -> FCode CmmLit
newByteStringCLit ByteString
s
 -- not unpackFS; we want the UTF-8 byte stream.
cgLit Literal
other_lit     = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                         CmmLit -> FCode CmmLit
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Literal -> CmmLit
mkSimpleLit DynFlags
dflags Literal
other_lit)

mkSimpleLit :: DynFlags -> Literal -> CmmLit
mkSimpleLit :: DynFlags -> Literal -> CmmLit
mkSimpleLit DynFlags
dflags (LitChar   Char
c)                = Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c))
                                                         (DynFlags -> Width
wordWidth DynFlags
dflags)
mkSimpleLit DynFlags
dflags Literal
LitNullAddr                  = DynFlags -> CmmLit
zeroCLit DynFlags
dflags
mkSimpleLit DynFlags
dflags (LitNumber LitNumType
LitNumInt Integer
i Type
_)    = Integer -> Width -> CmmLit
CmmInt Integer
i (DynFlags -> Width
wordWidth DynFlags
dflags)
mkSimpleLit DynFlags
_      (LitNumber LitNumType
LitNumInt64 Integer
i Type
_)  = Integer -> Width -> CmmLit
CmmInt Integer
i Width
W64
mkSimpleLit DynFlags
dflags (LitNumber LitNumType
LitNumWord Integer
i Type
_)   = Integer -> Width -> CmmLit
CmmInt Integer
i (DynFlags -> Width
wordWidth DynFlags
dflags)
mkSimpleLit DynFlags
_      (LitNumber LitNumType
LitNumWord64 Integer
i Type
_) = Integer -> Width -> CmmLit
CmmInt Integer
i Width
W64
mkSimpleLit DynFlags
_      (LitFloat Rational
r)                 = Rational -> Width -> CmmLit
CmmFloat Rational
r Width
W32
mkSimpleLit DynFlags
_      (LitDouble Rational
r)                = Rational -> Width -> CmmLit
CmmFloat Rational
r Width
W64
mkSimpleLit DynFlags
_      (LitLabel FastString
fs Maybe Int
ms FunctionOrData
fod)
  = let -- TODO: Literal labels might not actually be in the current package...
        labelSrc :: ForeignLabelSource
labelSrc = ForeignLabelSource
ForeignLabelInThisPackage
    in CLabel -> CmmLit
CmmLabel (FastString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
fs Maybe Int
ms ForeignLabelSource
labelSrc FunctionOrData
fod)
-- NB: LitRubbish should have been lowered in "CoreToStg"
mkSimpleLit DynFlags
_      Literal
other = String -> SDoc -> CmmLit
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkSimpleLit" (Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
other)

--------------------------------------------------------------------------
--
-- Incrementing a memory location
--
--------------------------------------------------------------------------

addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl CmmType
rep CLabel
lbl Int
n = CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem CmmType
rep (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl)) Int
n

addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
addToMemLblE CmmType
rep CLabel
lbl = CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE CmmType
rep (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl))

addToMem :: CmmType     -- rep of the counter
         -> CmmExpr     -- Address
         -> Int         -- What to add (a word)
         -> CmmAGraph
addToMem :: CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem CmmType
rep CmmExpr
ptr Int
n = CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE CmmType
rep CmmExpr
ptr (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n) (CmmType -> Width
typeWidth CmmType
rep)))

addToMemE :: CmmType    -- rep of the counter
          -> CmmExpr    -- Address
          -> CmmExpr    -- What to add (a word-typed expression)
          -> CmmAGraph
addToMemE :: CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE CmmType
rep CmmExpr
ptr CmmExpr
n
  = CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
ptr (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add (CmmType -> Width
typeWidth CmmType
rep)) [CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
ptr CmmType
rep, CmmExpr
n])


-------------------------------------------------------------------------
--
--      Loading a field from an object,
--      where the object pointer is itself tagged
--
-------------------------------------------------------------------------

mkTaggedObjectLoad
  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
-- (loadTaggedObjectField reg base off tag) generates assignment
--      reg = bitsK[ base + off - tag ]
-- where K is fixed by 'reg'
mkTaggedObjectLoad :: DynFlags -> LocalReg -> LocalReg -> Int -> Int -> CmmAGraph
mkTaggedObjectLoad DynFlags
dflags LocalReg
reg LocalReg
base Int
offset Int
tag
  = CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg)
             (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags
                                  (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
base))
                                  (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tag))
                      (LocalReg -> CmmType
localRegType LocalReg
reg))

-------------------------------------------------------------------------
--
--      Converting a closure tag to a closure for enumeration types
--      (this is the implementation of tagToEnum#).
--
-------------------------------------------------------------------------

tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
tagToClosure DynFlags
dflags TyCon
tycon CmmExpr
tag
  = CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprW DynFlags
dflags CmmExpr
closure_tbl CmmExpr
tag) (DynFlags -> CmmType
bWord DynFlags
dflags)
  where closure_tbl :: CmmExpr
closure_tbl = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl)
        lbl :: CLabel
lbl = Name -> CafInfo -> CLabel
mkClosureTableLabel (TyCon -> Name
tyConName TyCon
tycon) CafInfo
NoCafRefs

-------------------------------------------------------------------------
--
--      Conditionals and rts calls
--
-------------------------------------------------------------------------

emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall :: UnitId
-> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCall UnitId
pkg FastString
fun [(CmmExpr, ForeignHint)]
args Bool
safe = [(LocalReg, ForeignHint)]
-> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCallGen [] (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
pkg FastString
fun) [(CmmExpr, ForeignHint)]
args Bool
safe

emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult :: LocalReg
-> ForeignHint
-> UnitId
-> FastString
-> [(CmmExpr, ForeignHint)]
-> Bool
-> FCode ()
emitRtsCallWithResult LocalReg
res ForeignHint
hint UnitId
pkg FastString
fun [(CmmExpr, ForeignHint)]
args Bool
safe
   = [(LocalReg, ForeignHint)]
-> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCallGen [(LocalReg
res,ForeignHint
hint)] (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
pkg FastString
fun) [(CmmExpr, ForeignHint)]
args Bool
safe

-- Make a call to an RTS C procedure
emitRtsCallGen
   :: [(LocalReg,ForeignHint)]
   -> CLabel
   -> [(CmmExpr,ForeignHint)]
   -> Bool -- True <=> CmmSafe call
   -> FCode ()
emitRtsCallGen :: [(LocalReg, ForeignHint)]
-> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCallGen [(LocalReg, ForeignHint)]
res CLabel
lbl [(CmmExpr, ForeignHint)]
args Bool
safe
  = do { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; Int
updfr_off <- FCode Int
getUpdFrameOff
       ; let (CmmAGraph
caller_save, CmmAGraph
caller_load) = DynFlags -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs DynFlags
dflags
       ; CmmAGraph -> FCode ()
emit CmmAGraph
caller_save
       ; Int -> FCode ()
call Int
updfr_off
       ; CmmAGraph -> FCode ()
emit CmmAGraph
caller_load }
  where
    call :: Int -> FCode ()
call Int
updfr_off =
      if Bool
safe then
        CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> [LocalReg] -> [CmmExpr] -> Int -> FCode CmmAGraph
mkCmmCall CmmExpr
fun_expr [LocalReg]
res' [CmmExpr]
args' Int
updfr_off
      else do
        let conv :: ForeignConvention
conv = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint]
arg_hints [ForeignHint]
res_hints CmmReturnInfo
CmmMayReturn
        CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmAGraph
mkUnsafeCall (CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
fun_expr ForeignConvention
conv) [LocalReg]
res' [CmmExpr]
args'
    ([CmmExpr]
args', [ForeignHint]
arg_hints) = [(CmmExpr, ForeignHint)] -> ([CmmExpr], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmExpr, ForeignHint)]
args
    ([LocalReg]
res',  [ForeignHint]
res_hints) = [(LocalReg, ForeignHint)] -> ([LocalReg], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(LocalReg, ForeignHint)]
res
    fun_expr :: CmmExpr
fun_expr = CLabel -> CmmExpr
mkLblExpr CLabel
lbl


-----------------------------------------------------------------------------
--
--      Caller-Save Registers
--
-----------------------------------------------------------------------------

-- Here we generate the sequence of saves/restores required around a
-- foreign call instruction.

-- TODO: reconcile with includes/Regs.h
--  * Regs.h claims that BaseReg should be saved last and loaded first
--    * This might not have been tickled before since BaseReg is callee save
--  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
--
-- This code isn't actually used right now, because callerSaves
-- only ever returns true in the current universe for registers NOT in
-- system_regs (just do a grep for CALLER_SAVES in
-- includes/stg/MachRegs.h).  It's all one giant no-op, and for
-- good reason: having to save system registers on every foreign call
-- would be very expensive, so we avoid assigning them to those
-- registers when we add support for an architecture.
--
-- Note that the old code generator actually does more work here: it
-- also saves other global registers.  We can't (nor want) to do that
-- here, as we don't have liveness information.  And really, we
-- shouldn't be doing the workaround at this point in the pipeline, see
-- Note [Register parameter passing] and the ToDo on CmmCall in
-- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across
-- unsafe foreign calls in rewriteAssignments, but this is strictly
-- temporary.
callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs DynFlags
dflags = (CmmAGraph
caller_save, CmmAGraph
caller_load)
  where
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

    caller_save :: CmmAGraph
caller_save = [CmmAGraph] -> CmmAGraph
catAGraphs ((GlobalReg -> CmmAGraph) -> [GlobalReg] -> [CmmAGraph]
forall a b. (a -> b) -> [a] -> [b]
map GlobalReg -> CmmAGraph
callerSaveGlobalReg    [GlobalReg]
regs_to_save)
    caller_load :: CmmAGraph
caller_load = [CmmAGraph] -> CmmAGraph
catAGraphs ((GlobalReg -> CmmAGraph) -> [GlobalReg] -> [CmmAGraph]
forall a b. (a -> b) -> [a] -> [b]
map GlobalReg -> CmmAGraph
callerRestoreGlobalReg [GlobalReg]
regs_to_save)

    system_regs :: [GlobalReg]
system_regs = [ GlobalReg
Sp,GlobalReg
SpLim,GlobalReg
Hp,GlobalReg
HpLim,GlobalReg
CCCS,GlobalReg
CurrentTSO,GlobalReg
CurrentNursery
                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
                  , GlobalReg
BaseReg ]

    regs_to_save :: [GlobalReg]
regs_to_save = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> GlobalReg -> Bool
callerSaves Platform
platform) [GlobalReg]
system_regs

    callerSaveGlobalReg :: GlobalReg -> CmmAGraph
callerSaveGlobalReg GlobalReg
reg
        = CmmExpr -> CmmExpr -> CmmAGraph
mkStore (DynFlags -> GlobalReg -> CmmExpr
get_GlobalReg_addr DynFlags
dflags GlobalReg
reg) (CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
reg))

    callerRestoreGlobalReg :: GlobalReg -> CmmAGraph
callerRestoreGlobalReg GlobalReg
reg
        = CmmReg -> CmmExpr -> CmmAGraph
mkAssign (GlobalReg -> CmmReg
CmmGlobal GlobalReg
reg)
                   (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> GlobalReg -> CmmExpr
get_GlobalReg_addr DynFlags
dflags GlobalReg
reg) (DynFlags -> GlobalReg -> CmmType
globalRegType DynFlags
dflags GlobalReg
reg))


-------------------------------------------------------------------------
--
--      Strings generate a top-level data block
--
-------------------------------------------------------------------------

emitDataLits :: CLabel -> [CmmLit] -> FCode ()
-- Emit a data-segment data block
emitDataLits :: CLabel -> [CmmLit] -> FCode ()
emitDataLits CLabel
lbl [CmmLit]
lits = CmmDecl -> FCode ()
emitDecl (Section -> CLabel -> [CmmLit] -> CmmDecl
forall info stmt.
Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkDataLits (SectionType -> CLabel -> Section
Section SectionType
Data CLabel
lbl) CLabel
lbl [CmmLit]
lits)

emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
-- Emit a read-only data block
emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
emitRODataLits CLabel
lbl [CmmLit]
lits = CmmDecl -> FCode ()
emitDecl (CLabel -> [CmmLit] -> CmmDecl
forall info stmt.
CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkRODataLits CLabel
lbl [CmmLit]
lits)

newStringCLit :: String -> FCode CmmLit
-- Make a global definition for the string,
-- and return its label
newStringCLit :: String -> FCode CmmLit
newStringCLit String
str = ByteString -> FCode CmmLit
newByteStringCLit (String -> ByteString
BS8.pack String
str)

newByteStringCLit :: ByteString -> FCode CmmLit
newByteStringCLit :: ByteString -> FCode CmmLit
newByteStringCLit ByteString
bytes
  = do  { Unique
uniq <- FCode Unique
newUnique
        ; let (CmmLit
lit, GenCmmDecl CmmStatics info stmt
decl) = CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)
forall info stmt.
CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)
mkByteStringCLit (Unique -> CLabel
mkStringLitLabel Unique
uniq) ByteString
bytes
        ; CmmDecl -> FCode ()
emitDecl CmmDecl
forall info stmt. GenCmmDecl CmmStatics info stmt
decl
        ; CmmLit -> FCode CmmLit
forall (m :: * -> *) a. Monad m => a -> m a
return CmmLit
lit }

-------------------------------------------------------------------------
--
--      Assigning expressions to temporaries
--
-------------------------------------------------------------------------

assignTemp :: CmmExpr -> FCode LocalReg
-- Make sure the argument is in a local register.
-- We don't bother being particularly aggressive with avoiding
-- unnecessary local registers, since we can rely on a later
-- optimization pass to inline as necessary (and skipping out
-- on things like global registers can be a little dangerous
-- due to them being trashed on foreign calls--though it means
-- the optimization pass doesn't have to do as much work)
assignTemp :: CmmExpr -> FCode LocalReg
assignTemp (CmmReg (CmmLocal LocalReg
reg)) = LocalReg -> FCode LocalReg
forall (m :: * -> *) a. Monad m => a -> m a
return LocalReg
reg
assignTemp CmmExpr
e = do { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                  ; Unique
uniq <- FCode Unique
newUnique
                  ; let reg :: LocalReg
reg = Unique -> CmmType -> LocalReg
LocalReg Unique
uniq (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
e)
                  ; CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg) CmmExpr
e
                  ; LocalReg -> FCode LocalReg
forall (m :: * -> *) a. Monad m => a -> m a
return LocalReg
reg }

newTemp :: MonadUnique m => CmmType -> m LocalReg
newTemp :: CmmType -> m LocalReg
newTemp CmmType
rep = do { Unique
uniq <- m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
                 ; LocalReg -> m LocalReg
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> CmmType -> LocalReg
LocalReg Unique
uniq CmmType
rep) }

newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
-- Choose suitable local regs to use for the components
-- of an unboxed tuple that we are about to return to
-- the Sequel.  If the Sequel is a join point, using the
-- regs it wants will save later assignments.
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
newUnboxedTupleRegs Type
res_ty
  = ASSERT( isUnboxedTupleType res_ty )
    do  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; Sequel
sequel <- FCode Sequel
getSequel
        ; [LocalReg]
regs <- DynFlags -> Sequel -> FCode [LocalReg]
forall (m :: * -> *).
MonadUnique m =>
DynFlags -> Sequel -> m [LocalReg]
choose_regs DynFlags
dflags Sequel
sequel
        ; ASSERT( regs `equalLength` reps )
          ([LocalReg], [ForeignHint]) -> FCode ([LocalReg], [ForeignHint])
forall (m :: * -> *) a. Monad m => a -> m a
return ([LocalReg]
regs, (PrimRep -> ForeignHint) -> [PrimRep] -> [ForeignHint]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> ForeignHint
primRepForeignHint [PrimRep]
reps) }
  where
    reps :: [PrimRep]
reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
res_ty
    choose_regs :: DynFlags -> Sequel -> m [LocalReg]
choose_regs DynFlags
_ (AssignTo [LocalReg]
regs Bool
_) = [LocalReg] -> m [LocalReg]
forall (m :: * -> *) a. Monad m => a -> m a
return [LocalReg]
regs
    choose_regs DynFlags
dflags Sequel
_            = (PrimRep -> m LocalReg) -> [PrimRep] -> m [LocalReg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (CmmType -> m LocalReg)
-> (PrimRep -> CmmType) -> PrimRep -> m LocalReg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PrimRep -> CmmType
primRepCmmType DynFlags
dflags) [PrimRep]
reps



-------------------------------------------------------------------------
--      emitMultiAssign
-------------------------------------------------------------------------

emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
-- Emit code to perform the assignments in the
-- input simultaneously, using temporary variables when necessary.

type Key  = Int
type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
                        -- for fast comparison
type Stmt = (LocalReg, CmmExpr) -- r := e

-- We use the strongly-connected component algorithm, in which
--      * the vertices are the statements
--      * an edge goes from s1 to s2 iff
--              s1 assigns to something s2 uses
--        that is, if s1 should *follow* s2 in the final order

emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
emitMultiAssign []    []    = () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
emitMultiAssign [LocalReg
reg] [CmmExpr
rhs] = CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg) CmmExpr
rhs
emitMultiAssign [LocalReg]
regs [CmmExpr]
rhss   = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )
    DynFlags -> [Vrtx] -> FCode ()
unscramble DynFlags
dflags ([Int
1..] [Int] -> [(LocalReg, CmmExpr)] -> [Vrtx]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ([LocalReg]
regs [LocalReg] -> [CmmExpr] -> [(LocalReg, CmmExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CmmExpr]
rhss))

unscramble :: DynFlags -> [Vrtx] -> FCode ()
unscramble :: DynFlags -> [Vrtx] -> FCode ()
unscramble DynFlags
dflags [Vrtx]
vertices = (SCC Vrtx -> FCode ()) -> [SCC Vrtx] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SCC Vrtx -> FCode ()
do_component [SCC Vrtx]
components
  where
        edges :: [ Node Key Vrtx ]
        edges :: [Node Int Vrtx]
edges = [ Vrtx -> Int -> [Int] -> Node Int Vrtx
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode Vrtx
vertex Int
key1 ((LocalReg, CmmExpr) -> [Int]
edges_from (LocalReg, CmmExpr)
stmt1)
                | vertex :: Vrtx
vertex@(Int
key1, (LocalReg, CmmExpr)
stmt1) <- [Vrtx]
vertices ]

        edges_from :: Stmt -> [Key]
        edges_from :: (LocalReg, CmmExpr) -> [Int]
edges_from (LocalReg, CmmExpr)
stmt1 = [ Int
key2 | (Int
key2, (LocalReg, CmmExpr)
stmt2) <- [Vrtx]
vertices,
                                    (LocalReg, CmmExpr)
stmt1 (LocalReg, CmmExpr) -> (LocalReg, CmmExpr) -> Bool
`mustFollow` (LocalReg, CmmExpr)
stmt2 ]

        components :: [SCC Vrtx]
        components :: [SCC Vrtx]
components = [Node Int Vrtx] -> [SCC Vrtx]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Int Vrtx]
edges

        -- do_components deal with one strongly-connected component
        -- Not cyclic, or singleton?  Just do it
        do_component :: SCC Vrtx -> FCode ()
        do_component :: SCC Vrtx -> FCode ()
do_component (AcyclicSCC (Int
_,(LocalReg, CmmExpr)
stmt))  = (LocalReg, CmmExpr) -> FCode ()
mk_graph (LocalReg, CmmExpr)
stmt
        do_component (CyclicSCC [])         = String -> FCode ()
forall a. String -> a
panic String
"do_component"
        do_component (CyclicSCC [(Int
_,(LocalReg, CmmExpr)
stmt)]) = (LocalReg, CmmExpr) -> FCode ()
mk_graph (LocalReg, CmmExpr)
stmt

                -- Cyclic?  Then go via temporaries.  Pick one to
                -- break the loop and try again with the rest.
        do_component (CyclicSCC ((Int
_,(LocalReg, CmmExpr)
first_stmt) : [Vrtx]
rest)) = do
            DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            Unique
u <- FCode Unique
newUnique
            let ((LocalReg, CmmExpr)
to_tmp, (LocalReg, CmmExpr)
from_tmp) = DynFlags
-> Unique
-> (LocalReg, CmmExpr)
-> ((LocalReg, CmmExpr), (LocalReg, CmmExpr))
split DynFlags
dflags Unique
u (LocalReg, CmmExpr)
first_stmt
            (LocalReg, CmmExpr) -> FCode ()
mk_graph (LocalReg, CmmExpr)
to_tmp
            DynFlags -> [Vrtx] -> FCode ()
unscramble DynFlags
dflags [Vrtx]
rest
            (LocalReg, CmmExpr) -> FCode ()
mk_graph (LocalReg, CmmExpr)
from_tmp

        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
        split :: DynFlags
-> Unique
-> (LocalReg, CmmExpr)
-> ((LocalReg, CmmExpr), (LocalReg, CmmExpr))
split DynFlags
dflags Unique
uniq (LocalReg
reg, CmmExpr
rhs)
          = ((LocalReg
tmp, CmmExpr
rhs), (LocalReg
reg, CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tmp)))
          where
            rep :: CmmType
rep = DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
rhs
            tmp :: LocalReg
tmp = Unique -> CmmType -> LocalReg
LocalReg Unique
uniq CmmType
rep

        mk_graph :: Stmt -> FCode ()
        mk_graph :: (LocalReg, CmmExpr) -> FCode ()
mk_graph (LocalReg
reg, CmmExpr
rhs) = CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg) CmmExpr
rhs

        mustFollow :: Stmt -> Stmt -> Bool
        (LocalReg
reg, CmmExpr
_) mustFollow :: (LocalReg, CmmExpr) -> (LocalReg, CmmExpr) -> Bool
`mustFollow` (LocalReg
_, CmmExpr
rhs) = DynFlags -> CmmReg -> CmmExpr -> Bool
regUsedIn DynFlags
dflags (LocalReg -> CmmReg
CmmLocal LocalReg
reg) CmmExpr
rhs

-------------------------------------------------------------------------
--      mkSwitch
-------------------------------------------------------------------------


emitSwitch :: CmmExpr                      -- Tag to switch on
           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
           -> Maybe CmmAGraphScoped        -- Default branch (if any)
           -> ConTagZ -> ConTagZ           -- Min and Max possible values;
                                           -- behaviour outside this range is
                                           -- undefined
           -> FCode ()

-- First, two rather common cases in which there is no work to do
emitSwitch :: CmmExpr
-> [(Int, CmmAGraphScoped)]
-> Maybe CmmAGraphScoped
-> Int
-> Int
-> FCode ()
emitSwitch CmmExpr
_ []         (Just CmmAGraphScoped
code) Int
_ Int
_ = CmmAGraph -> FCode ()
emit (CmmAGraphScoped -> CmmAGraph
forall a b. (a, b) -> a
fst CmmAGraphScoped
code)
emitSwitch CmmExpr
_ [(Int
_,CmmAGraphScoped
code)] Maybe CmmAGraphScoped
Nothing     Int
_ Int
_ = CmmAGraph -> FCode ()
emit (CmmAGraphScoped -> CmmAGraph
forall a b. (a, b) -> a
fst CmmAGraphScoped
code)

-- Right, off we go
emitSwitch CmmExpr
tag_expr [(Int, CmmAGraphScoped)]
branches Maybe CmmAGraphScoped
mb_deflt Int
lo_tag Int
hi_tag = do
    BlockId
join_lbl      <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
    Maybe BlockId
mb_deflt_lbl  <- BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
label_default BlockId
join_lbl Maybe CmmAGraphScoped
mb_deflt
    [(Int, BlockId)]
branches_lbls <- BlockId -> [(Int, CmmAGraphScoped)] -> FCode [(Int, BlockId)]
forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
label_branches BlockId
join_lbl [(Int, CmmAGraphScoped)]
branches
    CmmExpr
tag_expr'     <- CmmExpr -> FCode CmmExpr
assignTemp' CmmExpr
tag_expr

    -- Sort the branches before calling mk_discrete_switch
    let branches_lbls' :: [(Integer, BlockId)]
branches_lbls' = [ (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i, BlockId
l) | (Int
i,BlockId
l) <- ((Int, BlockId) -> (Int, BlockId) -> Ordering)
-> [(Int, BlockId)] -> [(Int, BlockId)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, BlockId) -> Int)
-> (Int, BlockId) -> (Int, BlockId) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, BlockId) -> Int
forall a b. (a, b) -> a
fst) [(Int, BlockId)]
branches_lbls ]
    let range :: (Integer, Integer)
range = (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lo_tag, Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hi_tag)

    CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ Bool
-> CmmExpr
-> [(Integer, BlockId)]
-> Maybe BlockId
-> (Integer, Integer)
-> CmmAGraph
mk_discrete_switch Bool
False CmmExpr
tag_expr' [(Integer, BlockId)]
branches_lbls' Maybe BlockId
mb_deflt_lbl (Integer, Integer)
range

    BlockId -> FCode ()
emitLabel BlockId
join_lbl

mk_discrete_switch :: Bool -- ^ Use signed comparisons
          -> CmmExpr
          -> [(Integer, BlockId)]
          -> Maybe BlockId
          -> (Integer, Integer)
          -> CmmAGraph

-- SINGLETON TAG RANGE: no case analysis to do
mk_discrete_switch :: Bool
-> CmmExpr
-> [(Integer, BlockId)]
-> Maybe BlockId
-> (Integer, Integer)
-> CmmAGraph
mk_discrete_switch Bool
_ CmmExpr
_tag_expr [(Integer
tag, BlockId
lbl)] Maybe BlockId
_ (Integer
lo_tag, Integer
hi_tag)
  | Integer
lo_tag Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
hi_tag
  = ASSERT( tag == lo_tag )
    BlockId -> CmmAGraph
mkBranch BlockId
lbl

-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
mk_discrete_switch Bool
_ CmmExpr
_tag_expr [(Integer
_tag,BlockId
lbl)] Maybe BlockId
Nothing (Integer, Integer)
_
  = BlockId -> CmmAGraph
mkBranch BlockId
lbl
        -- The simplifier might have eliminated a case
        --       so we may have e.g. case xs of
        --                               [] -> e
        -- In that situation we can be sure the (:) case
        -- can't happen, so no need to test

-- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans
-- See Note [Cmm Switches, the general plan] in CmmSwitch
mk_discrete_switch Bool
signed CmmExpr
tag_expr [(Integer, BlockId)]
branches Maybe BlockId
mb_deflt (Integer, Integer)
range
  = CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch CmmExpr
tag_expr (SwitchTargets -> CmmAGraph) -> SwitchTargets -> CmmAGraph
forall a b. (a -> b) -> a -> b
$ Bool
-> (Integer, Integer)
-> Maybe BlockId
-> Map Integer BlockId
-> SwitchTargets
mkSwitchTargets Bool
signed (Integer, Integer)
range Maybe BlockId
mb_deflt ([(Integer, BlockId)] -> Map Integer BlockId
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Integer, BlockId)]
branches)

divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
divideBranches :: [(a, b)] -> ([(a, b)], a, [(a, b)])
divideBranches [(a, b)]
branches = ([(a, b)]
lo_branches, a
mid, [(a, b)]
hi_branches)
  where
    -- 2 branches => n_branches `div` 2 = 1
    --            => branches !! 1 give the *second* tag
    -- There are always at least 2 branches here
    (a
mid,b
_) = [(a, b)]
branches [(a, b)] -> Int -> (a, b)
forall a. [a] -> Int -> a
!! ([(a, b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, b)]
branches Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
    ([(a, b)]
lo_branches, [(a, b)]
hi_branches) = ((a, b) -> Bool) -> [(a, b)] -> ([(a, b)], [(a, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a, b) -> Bool
forall b. (a, b) -> Bool
is_lo [(a, b)]
branches
    is_lo :: (a, b) -> Bool
is_lo (a
t,b
_) = a
t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
mid

--------------
emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on
               -> [(Literal, CmmAGraphScoped)] -- Tagged branches
               -> CmmAGraphScoped              -- Default branch (always)
               -> FCode ()                     -- Emit the code
emitCmmLitSwitch :: CmmExpr
-> [(Literal, CmmAGraphScoped)] -> CmmAGraphScoped -> FCode ()
emitCmmLitSwitch CmmExpr
_scrut []       CmmAGraphScoped
deflt = CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmAGraphScoped -> CmmAGraph
forall a b. (a, b) -> a
fst CmmAGraphScoped
deflt
emitCmmLitSwitch CmmExpr
scrut  [(Literal, CmmAGraphScoped)]
branches CmmAGraphScoped
deflt = do
    CmmExpr
scrut' <- CmmExpr -> FCode CmmExpr
assignTemp' CmmExpr
scrut
    BlockId
join_lbl <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
    BlockId
deflt_lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl CmmAGraphScoped
deflt
    [(Literal, BlockId)]
branches_lbls <- BlockId
-> [(Literal, CmmAGraphScoped)] -> FCode [(Literal, BlockId)]
forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
label_branches BlockId
join_lbl [(Literal, CmmAGraphScoped)]
branches

    DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let cmm_ty :: CmmType
cmm_ty = DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
scrut
        rep :: Width
rep = CmmType -> Width
typeWidth CmmType
cmm_ty

    -- We find the necessary type information in the literals in the branches
    let signed :: Bool
signed = case [(Literal, CmmAGraphScoped)] -> (Literal, CmmAGraphScoped)
forall a. [a] -> a
head [(Literal, CmmAGraphScoped)]
branches of
                    (LitNumber LitNumType
nt Integer
_ Type
_, CmmAGraphScoped
_) -> LitNumType -> Bool
litNumIsSigned LitNumType
nt
                    (Literal, CmmAGraphScoped)
_ -> Bool
False

    let range :: (Integer, Integer)
range | Bool
signed    = (DynFlags -> Integer
tARGET_MIN_INT DynFlags
dflags, DynFlags -> Integer
tARGET_MAX_INT DynFlags
dflags)
              | Bool
otherwise = (Integer
0, DynFlags -> Integer
tARGET_MAX_WORD DynFlags
dflags)

    if CmmType -> Bool
isFloatType CmmType
cmm_ty
    then CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Width
-> CmmExpr
-> BlockId
-> LitBound
-> [(Literal, BlockId)]
-> FCode CmmAGraph
mk_float_switch Width
rep CmmExpr
scrut' BlockId
deflt_lbl LitBound
noBound [(Literal, BlockId)]
branches_lbls
    else CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ Bool
-> CmmExpr
-> [(Integer, BlockId)]
-> Maybe BlockId
-> (Integer, Integer)
-> CmmAGraph
mk_discrete_switch
        Bool
signed
        CmmExpr
scrut'
        [(Literal -> Integer
litValue Literal
lit,BlockId
l) | (Literal
lit,BlockId
l) <- [(Literal, BlockId)]
branches_lbls]
        (BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
deflt_lbl)
        (Integer, Integer)
range
    BlockId -> FCode ()
emitLabel BlockId
join_lbl

-- | lower bound (inclusive), upper bound (exclusive)
type LitBound = (Maybe Literal, Maybe Literal)

noBound :: LitBound
noBound :: LitBound
noBound = (Maybe Literal
forall a. Maybe a
Nothing, Maybe Literal
forall a. Maybe a
Nothing)

mk_float_switch :: Width -> CmmExpr -> BlockId
              -> LitBound
              -> [(Literal,BlockId)]
              -> FCode CmmAGraph
mk_float_switch :: Width
-> CmmExpr
-> BlockId
-> LitBound
-> [(Literal, BlockId)]
-> FCode CmmAGraph
mk_float_switch Width
rep CmmExpr
scrut BlockId
deflt LitBound
_bounds [(Literal
lit,BlockId
blk)]
  = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmAGraph -> FCode CmmAGraph) -> CmmAGraph -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch (DynFlags -> CmmExpr
cond DynFlags
dflags) BlockId
deflt BlockId
blk Maybe Bool
forall a. Maybe a
Nothing
  where
    cond :: DynFlags -> CmmExpr
cond DynFlags
dflags = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
ne [CmmExpr
scrut, CmmLit -> CmmExpr
CmmLit CmmLit
cmm_lit]
      where
        cmm_lit :: CmmLit
cmm_lit = DynFlags -> Literal -> CmmLit
mkSimpleLit DynFlags
dflags Literal
lit
        ne :: MachOp
ne      = Width -> MachOp
MO_F_Ne Width
rep

mk_float_switch Width
rep CmmExpr
scrut BlockId
deflt_blk_id (Maybe Literal
lo_bound, Maybe Literal
hi_bound) [(Literal, BlockId)]
branches
  = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       CmmAGraph
lo_blk <- Width
-> CmmExpr
-> BlockId
-> LitBound
-> [(Literal, BlockId)]
-> FCode CmmAGraph
mk_float_switch Width
rep CmmExpr
scrut BlockId
deflt_blk_id LitBound
bounds_lo [(Literal, BlockId)]
lo_branches
       CmmAGraph
hi_blk <- Width
-> CmmExpr
-> BlockId
-> LitBound
-> [(Literal, BlockId)]
-> FCode CmmAGraph
mk_float_switch Width
rep CmmExpr
scrut BlockId
deflt_blk_id LitBound
bounds_hi [(Literal, BlockId)]
hi_branches
       CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThenElse (DynFlags -> CmmExpr
cond DynFlags
dflags) CmmAGraph
lo_blk CmmAGraph
hi_blk
  where
    ([(Literal, BlockId)]
lo_branches, Literal
mid_lit, [(Literal, BlockId)]
hi_branches) = [(Literal, BlockId)]
-> ([(Literal, BlockId)], Literal, [(Literal, BlockId)])
forall a b. Ord a => [(a, b)] -> ([(a, b)], a, [(a, b)])
divideBranches [(Literal, BlockId)]
branches

    bounds_lo :: LitBound
bounds_lo = (Maybe Literal
lo_bound, Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
mid_lit)
    bounds_hi :: LitBound
bounds_hi = (Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
mid_lit, Maybe Literal
hi_bound)

    cond :: DynFlags -> CmmExpr
cond DynFlags
dflags = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
lt [CmmExpr
scrut, CmmLit -> CmmExpr
CmmLit CmmLit
cmm_lit]
      where
        cmm_lit :: CmmLit
cmm_lit = DynFlags -> Literal -> CmmLit
mkSimpleLit DynFlags
dflags Literal
mid_lit
        lt :: MachOp
lt      = Width -> MachOp
MO_F_Lt Width
rep


--------------
label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
label_default BlockId
_ Maybe CmmAGraphScoped
Nothing
  = Maybe BlockId -> FCode (Maybe BlockId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BlockId
forall a. Maybe a
Nothing
label_default BlockId
join_lbl (Just CmmAGraphScoped
code)
  = do BlockId
lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl CmmAGraphScoped
code
       Maybe BlockId -> FCode (Maybe BlockId)
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
lbl)

--------------
label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
label_branches :: BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
label_branches BlockId
_join_lbl []
  = [(a, BlockId)] -> FCode [(a, BlockId)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
label_branches BlockId
join_lbl ((a
tag,CmmAGraphScoped
code):[(a, CmmAGraphScoped)]
branches)
  = do BlockId
lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl CmmAGraphScoped
code
       [(a, BlockId)]
branches' <- BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
label_branches BlockId
join_lbl [(a, CmmAGraphScoped)]
branches
       [(a, BlockId)] -> FCode [(a, BlockId)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
tag,BlockId
lbl)(a, BlockId) -> [(a, BlockId)] -> [(a, BlockId)]
forall a. a -> [a] -> [a]
:[(a, BlockId)]
branches')

--------------
label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
--  label_code J code
--      generates
--  [L: code; goto J]
-- and returns L
label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl (CmmAGraph
code,CmmTickScope
tsc) = do
    BlockId
lbl <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
    BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine BlockId
lbl (CmmAGraph
code CmmAGraph -> CmmAGraph -> CmmAGraph
MkGraph.<*> BlockId -> CmmAGraph
mkBranch BlockId
join_lbl, CmmTickScope
tsc)
    BlockId -> FCode BlockId
forall (m :: * -> *) a. Monad m => a -> m a
return BlockId
lbl

--------------
assignTemp' :: CmmExpr -> FCode CmmExpr
assignTemp' :: CmmExpr -> FCode CmmExpr
assignTemp' CmmExpr
e
  | CmmExpr -> Bool
isTrivialCmmExpr CmmExpr
e = CmmExpr -> FCode CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CmmExpr
e
  | Bool
otherwise = do
       DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       LocalReg
lreg <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
e)
       let reg :: CmmReg
reg = LocalReg -> CmmReg
CmmLocal LocalReg
lreg
       CmmReg -> CmmExpr -> FCode ()
emitAssign CmmReg
reg CmmExpr
e
       CmmExpr -> FCode CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmReg -> CmmExpr
CmmReg CmmReg
reg)


---------------------------------------------------------------------------
-- Pushing to the update remembered set
---------------------------------------------------------------------------

whenUpdRemSetEnabled :: DynFlags -> FCode a -> FCode ()
whenUpdRemSetEnabled :: DynFlags -> FCode a -> FCode ()
whenUpdRemSetEnabled DynFlags
dflags FCode a
code = do
    CmmAGraph
do_it <- FCode a -> FCode CmmAGraph
forall a. FCode a -> FCode CmmAGraph
getCode FCode a
code
    CmmAGraph
the_if <- CmmExpr -> CmmAGraph -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThenElse' CmmExpr
is_enabled CmmAGraph
do_it CmmAGraph
mkNop (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
    CmmAGraph -> FCode ()
emit CmmAGraph
the_if
  where
    enabled :: CmmExpr
enabled = CmmExpr -> CmmType -> CmmExpr
CmmLoad (CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ CLabel -> CmmLit
CmmLabel CLabel
mkNonmovingWriteBarrierEnabledLabel) (DynFlags -> CmmType
bWord DynFlags
dflags)
    zero :: CmmExpr
zero = DynFlags -> CmmExpr
zeroExpr DynFlags
dflags
    is_enabled :: CmmExpr
is_enabled = DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmNeWord DynFlags
dflags CmmExpr
enabled CmmExpr
zero

-- | Emit code to add an entry to a now-overwritten pointer to the update
-- remembered set.
emitUpdRemSetPush :: CmmExpr   -- ^ value of pointer which was overwritten
                  -> FCode ()
emitUpdRemSetPush :: CmmExpr -> FCode ()
emitUpdRemSetPush CmmExpr
ptr = do
    UnitId
-> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCall
      UnitId
rtsUnitId
      (String -> FastString
fsLit String
"updateRemembSetPushClosure_")
      [(CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
BaseReg), ForeignHint
AddrHint),
       (CmmExpr
ptr, ForeignHint
AddrHint)]
      Bool
False

emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk
                       -> FCode ()
emitUpdRemSetPushThunk :: CmmExpr -> FCode ()
emitUpdRemSetPushThunk CmmExpr
ptr = do
    UnitId
-> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCall
      UnitId
rtsUnitId
      (String -> FastString
fsLit String
"updateRemembSetPushThunk_")
      [(CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
BaseReg), ForeignHint
AddrHint),
       (CmmExpr
ptr, ForeignHint
AddrHint)]
      Bool
False