Skip to content

GitLab

GHC
GHC
Commit 56042256 authored by Simon Marlow's avatar Simon Marlow
Browse files
Options

Support the 2-result primops in the new code generator

parent bf32abda
Hide whitespace changes
Inline Side-by-side
Showing with 176 additions and 7 deletions
compiler/cmm/CmmCvt.hs
View file @ 56042256
......@@ -12,7 +12,7 @@ import CmmUtils
import qualified OldCmm as Old
import OldPprCmm ()
import Hoopl hiding ((<*>), mkLabel, mkBranch)
import Hoopl
import Data.Maybe
import Maybes
import Outputable
......
compiler/cmm/CmmLayoutStack.hs
View file @ 56042256
......@@ -16,7 +16,7 @@ import ForeignCall
import CmmLive
import CmmProcPoint
import SMRep
import Hoopl hiding ((<*>), mkLast, mkMiddle)
import Hoopl
import Constants
import UniqSupply
import Maybes
......
compiler/cmm/CmmRewriteAssignments.hs
View file @ 56042256
......@@ -27,6 +27,7 @@ import Unique
import BlockId
import Hoopl
import Compiler.Hoopl ((<*>), mkMiddle, mkLast)
import Data.Maybe
import Control.Monad
import Prelude hiding (succ, zip)
......
compiler/cmm/Hoopl.hs
View file @ 56042256
......@@ -7,7 +7,8 @@ module Hoopl (
) where
import Compiler.Hoopl hiding
( Unique,
( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph
Unique,
FwdTransfer(..), FwdRewrite(..), FwdPass(..),
BwdTransfer(..), BwdRewrite(..), BwdPass(..),
noFwdRewrite, noBwdRewrite,
......
compiler/codeGen/StgCmmHeap.hs
View file @ 56042256
......@@ -33,7 +33,7 @@ import StgCmmEnv
import MkGraph
import Hoopl hiding ((<*>), mkBranch)
import Hoopl
import SMRep
import Cmm
import CmmUtils
......
compiler/codeGen/StgCmmPrim.hs
View file @ 56042256
......@@ -30,6 +30,8 @@ import StgCmmTicky
import StgCmmHeap
import StgCmmProf
import DynFlags
import Platform
import BasicTypes
import MkGraph
import StgSyn
......@@ -47,6 +49,8 @@ import Outputable
import StaticFlags
import Util
import Control.Monad (liftM)
------------------------------------------------------------------------
-- Primitive operations and foreign calls
------------------------------------------------------------------------
......@@ -508,9 +512,172 @@ emitPrimOp r@[res] op args
= let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
emit stmt
emitPrimOp _ op _
= pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
emitPrimOp results op args
= do dflags <- getDynFlags
case callishPrimOpSupported dflags op of
Left op -> emit $ mkUnsafeCall (PrimTarget op) results args
Right gen -> gen results args
type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp
callishPrimOpSupported dflags op
= case op of
IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem wordWidth)
| otherwise -> Right genericIntQuotRemOp
WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem wordWidth)
| otherwise -> Right genericWordQuotRemOp
WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 wordWidth)
| otherwise -> Right genericWordQuotRem2Op
WordAdd2Op | ncg && x86ish -> Left (MO_Add2 wordWidth)
| otherwise -> Right genericWordAdd2Op
WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 wordWidth)
| otherwise -> Right genericWordMul2Op
_ -> panic "emitPrimOp: can't translate PrimOp" (ppr op)
where
ncg = case hscTarget dflags of
HscAsm -> True
_ -> False
x86ish = case platformArch (targetPlatform dflags) of
ArchX86 -> True
ArchX86_64 -> True
_ -> False
genericIntQuotRemOp :: GenericOp
genericIntQuotRemOp [res_q, res_r] [arg_x, arg_y]
= emit $ mkAssign (CmmLocal res_q)
(CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]) <*>
mkAssign (CmmLocal res_r)
(CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])
genericIntQuotRemOp _ _ = panic "genericIntQuotRemOp"
genericWordQuotRemOp :: GenericOp
genericWordQuotRemOp [res_q, res_r] [arg_x, arg_y]
= emit $ mkAssign (CmmLocal res_q)
(CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]) <*>
mkAssign (CmmLocal res_r)
(CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])
genericWordQuotRemOp _ _ = panic "genericWordQuotRemOp"
genericWordQuotRem2Op :: GenericOp
genericWordQuotRem2Op [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
= emit =<< f (widthInBits wordWidth) zero arg_x_high arg_x_low
where ty = cmmExprType arg_x_high
shl x i = CmmMachOp (MO_Shl wordWidth) [x, i]
shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i]
or x y = CmmMachOp (MO_Or wordWidth) [x, y]
ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y]
ne x y = CmmMachOp (MO_Ne wordWidth) [x, y]
minus x y = CmmMachOp (MO_Sub wordWidth) [x, y]
times x y = CmmMachOp (MO_Mul wordWidth) [x, y]
zero = lit 0
one = lit 1
negone = lit (fromIntegral (widthInBits wordWidth) - 1)
lit i = CmmLit (CmmInt i wordWidth)
f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph
f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>
mkAssign (CmmLocal res_r) high)
f i acc high low =
do roverflowedBit <- newTemp ty
rhigh' <- newTemp ty
rhigh'' <- newTemp ty
rlow' <- newTemp ty
risge <- newTemp ty
racc' <- newTemp ty
let high' = CmmReg (CmmLocal rhigh')
isge = CmmReg (CmmLocal risge)
overflowedBit = CmmReg (CmmLocal roverflowedBit)
let this = catAGraphs
[mkAssign (CmmLocal roverflowedBit)
(shr high negone),
mkAssign (CmmLocal rhigh')
(or (shl high one) (shr low negone)),
mkAssign (CmmLocal rlow')
(shl low one),
mkAssign (CmmLocal risge)
(or (overflowedBit `ne` zero)
(high' `ge` arg_y)),
mkAssign (CmmLocal rhigh'')
(high' `minus` (arg_y `times` isge)),
mkAssign (CmmLocal racc')
(or (shl acc one) isge)]
rest <- f (i - 1) (CmmReg (CmmLocal racc'))
(CmmReg (CmmLocal rhigh''))
(CmmReg (CmmLocal rlow'))
return (this <*> rest)
genericWordQuotRem2Op _ _ = panic "genericWordQuotRem2Op"
genericWordAdd2Op :: GenericOp
genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
= do r1 <- newTemp (cmmExprType arg_x)
r2 <- newTemp (cmmExprType arg_x)
emit $ catAGraphs
[mkAssign (CmmLocal r1)
(add (bottomHalf arg_x) (bottomHalf arg_y)),
mkAssign (CmmLocal r2)
(add (topHalf (CmmReg (CmmLocal r1)))
(add (topHalf arg_x) (topHalf arg_y))),
mkAssign (CmmLocal res_h)
(topHalf (CmmReg (CmmLocal r2))),
mkAssign (CmmLocal res_l)
(or (toTopHalf (CmmReg (CmmLocal r2)))
(bottomHalf (CmmReg (CmmLocal r1))))]
where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww]
toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww]
bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm]
add x y = CmmMachOp (MO_Add wordWidth) [x, y]
or x y = CmmMachOp (MO_Or wordWidth) [x, y]
hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth))
wordWidth)
hwm = CmmLit (CmmInt halfWordMask wordWidth)
genericWordAdd2Op _ _ = panic "genericWordAdd2Op"
genericWordMul2Op :: GenericOp
genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
= do let t = cmmExprType arg_x
xlyl <- liftM CmmLocal $ newTemp t
xlyh <- liftM CmmLocal $ newTemp t
xhyl <- liftM CmmLocal $ newTemp t
r <- liftM CmmLocal $ newTemp t
-- This generic implementation is very simple and slow. We might
-- well be able to do better, but for now this at least works.
emit $ catAGraphs
[mkAssign xlyl
(mul (bottomHalf arg_x) (bottomHalf arg_y)),
mkAssign xlyh
(mul (bottomHalf arg_x) (topHalf arg_y)),
mkAssign xhyl
(mul (topHalf arg_x) (bottomHalf arg_y)),
mkAssign r
(sum [topHalf (CmmReg xlyl),
bottomHalf (CmmReg xhyl),
bottomHalf (CmmReg xlyh)]),
mkAssign (CmmLocal res_l)
(or (bottomHalf (CmmReg xlyl))
(toTopHalf (CmmReg r))),
mkAssign (CmmLocal res_h)
(sum [mul (topHalf arg_x) (topHalf arg_y),
topHalf (CmmReg xhyl),
topHalf (CmmReg xlyh),
topHalf (CmmReg r)])]
where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww]
toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww]
bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm]
add x y = CmmMachOp (MO_Add wordWidth) [x, y]
sum = foldl1 add
mul x y = CmmMachOp (MO_Mul wordWidth) [x, y]
or x y = CmmMachOp (MO_Or wordWidth) [x, y]
hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth))
wordWidth)
hwm = CmmLit (CmmInt halfWordMask wordWidth)
genericWordMul2Op _ _ = panic "genericWordMul2Op"
-- These PrimOps are NOPs in Cmm
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment