structure should not be too overwhelming.
\begin{code}
-module MachCode ( stmt2Instrs, InstrBlock ) where
+module MachCode ( stmtsToInstrs, InstrBlock ) where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
import MachRegs
import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
snocOL, consOL, concatOL )
-import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
-import CallConv ( CallConv )
-import CLabel ( isAsmTemp, CLabel, pprCLabel_asm )
-import Maybes ( maybeToBool, expectJust )
+import ForeignCall ( CCallConv(..) )
+import CLabel ( CLabel, labelDynamic )
+#if sparc_TARGET_ARCH || alpha_TARGET_ARCH
+import CLabel ( isAsmTemp )
+#endif
+import Maybes ( maybeToBool )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
-import CallConv ( cCallConv )
import Stix ( getNatLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..),
- pprStixTrees, ppStixReg,
+ DestInfo, hasDestInfo,
+ pprStixTree,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
getDeltaNat, setDeltaNat
)
import Outputable
+import CmdLineOpts ( opt_Static )
infixr 3 `bind`
Code extractor for an entire stix tree---stix statement level.
\begin{code}
-stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock
-
-stmt2Instrs stmt = case stmt of
+stmtsToInstrs :: [StixTree] -> NatM InstrBlock
+stmtsToInstrs stmts
+ = liftStrings stmts [] [] `thenNat` \ lifted ->
+ mapNat stmtToInstrs lifted `thenNat` \ instrss ->
+ returnNat (concatOL instrss)
+
+
+-- Lift StStrings out of top-level StDatas, putting them at the end of
+-- the block, and replacing them with StCLbls which refer to the lifted-out strings.
+{- Motivation for this hackery provided by the following bug:
+ Stix:
+ (DataSegment)
+ Bogon.ping_closure :
+ (Data P_ Addr.A#_static_info)
+ (Data StgAddr (Str `alalal'))
+ (Data P_ (0))
+ results in:
+ .data
+ .align 8
+ .global Bogon_ping_closure
+ Bogon_ping_closure:
+ .long Addr_Azh_static_info
+ .long .Ln1a8
+ .Ln1a8:
+ .byte 0x61
+ .byte 0x6C
+ .byte 0x61
+ .byte 0x6C
+ .byte 0x61
+ .byte 0x6C
+ .byte 0x00
+ .long 0
+ ie, the Str is planted in-line, when what we really meant was to place
+ a _reference_ to the string there. liftStrings will lift out all such
+ strings in top-level data and place them at the end of the block.
+
+ This is still a rather half-baked solution -- to do the job entirely right
+ would mean a complete traversal of all the Stixes, but there's currently no
+ real need for it, and it would be slow. Also, potentially there could be
+ literal types other than strings which need lifting out?
+-}
+
+liftStrings :: [StixTree] -- originals
+ -> [StixTree] -- (reverse) originals with strings lifted out
+ -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
+ -> NatM [StixTree]
+
+-- First, examine the original trees and lift out strings in top-level StDatas.
+liftStrings (st:sts) acc_stix acc_strs
+ = case st of
+ StData sz datas
+ -> lift datas acc_strs `thenNat` \ (datas_done, acc_strs1) ->
+ liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1
+ other
+ -> liftStrings sts (other:acc_stix) acc_strs
+ where
+ -- Handle a top-level StData
+ lift [] acc_strs = returnNat ([], acc_strs)
+ lift (d:ds) acc_strs
+ = lift ds acc_strs `thenNat` \ (ds_done, acc_strs1) ->
+ case d of
+ StString s
+ -> getNatLabelNCG `thenNat` \ lbl ->
+ returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
+ other
+ -> returnNat (other:ds_done, acc_strs1)
+
+-- When we've run out of original trees, emit the lifted strings.
+liftStrings [] acc_stix acc_strs
+ = returnNat (reverse acc_stix ++ concatMap f acc_strs)
+ where
+ f (lbl,str) = [StSegment RoDataSegment,
+ StLabel lbl,
+ StString str,
+ StSegment TextSegment]
+
+
+stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock
+stmtToInstrs stmt = case stmt of
StComment s -> returnNat (unitOL (COMMENT s))
StSegment seg -> returnNat (unitOL (SEGMENT seg))
StLabel lab -> returnNat (unitOL (LABEL lab))
- StJump arg -> genJump arg
- StCondJump lab arg -> genCondJump lab arg
- StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
+ StJump dsts arg -> genJump dsts (derefDLL arg)
+ StCondJump lab arg -> genCondJump lab (derefDLL arg)
+
+ -- A call returning void, ie one done for its side-effects
+ StCall fn cconv VoidRep args -> genCCall fn
+ cconv VoidRep (map derefDLL args)
StAssign pk dst src
- | isFloatingRep pk -> assignFltCode pk dst src
- | otherwise -> assignIntCode pk dst src
+ | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
+ | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
StFallThrough lbl
-- When falling through on the Alpha, we still have to load pv
`consOL` concatOL codes)
where
getData :: StixTree -> NatM (InstrBlock, Imm)
-
- getData (StInt i) = returnNat (nilOL, ImmInteger i)
- getData (StDouble d) = returnNat (nilOL, ImmDouble d)
- getData (StLitLbl s) = returnNat (nilOL, ImmLab s)
- getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
- getData (StString s) =
- getNatLabelNCG `thenNat` \ lbl ->
- returnNat (toOL [LABEL lbl,
- ASCII True (_UNPK_ s)],
- ImmCLbl lbl)
+ getData (StInt i) = returnNat (nilOL, ImmInteger i)
+ getData (StDouble d) = returnNat (nilOL, ImmDouble d)
+ getData (StFloat d) = returnNat (nilOL, ImmFloat d)
+ getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
+ getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
-- the linker can handle simple arithmetic...
getData (StIndex rep (StCLbl lbl) (StInt off)) =
- returnNat (nilOL,
- ImmIndex lbl (fromInteger (off * sizeOf rep)))
+ returnNat (nilOL,
+ ImmIndex lbl (fromInteger off * sizeOf rep))
+
+ -- Top-level lifted-out string. The segment will already have been set
+ -- (see liftStrings above).
+ StString str
+ -> returnNat (unitOL (ASCII True (_UNPK_ str)))
+
+
+-- Walk a Stix tree, and insert dereferences to CLabels which are marked
+-- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
+-- not all such CLabel occurrences need this dereferencing -- SRTs don't
+-- for one.
+derefDLL :: StixTree -> StixTree
+derefDLL tree
+ | opt_Static -- short out the entire deal if not doing DLLs
+ = tree
+ | otherwise
+ = qq tree
+ where
+ qq t
+ = case t of
+ StCLbl lbl -> if labelDynamic lbl
+ then StInd PtrRep (StCLbl lbl)
+ else t
+ -- all the rest are boring
+ StIndex pk base offset -> StIndex pk (qq base) (qq offset)
+ StPrim pk args -> StPrim pk (map qq args)
+ StInd pk addr -> StInd pk (qq addr)
+ StCall who cc pk args -> StCall who cc pk (map qq args)
+ StInt _ -> t
+ StFloat _ -> t
+ StDouble _ -> t
+ StString _ -> t
+ StReg _ -> t
+ StScratchWord _ -> t
+ _ -> pprPanic "derefDLL: unhandled case"
+ (pprStixTree t)
\end{code}
%************************************************************************
mangleIndexTree (StIndex pk base (StInt i))
= StPrim IntAddOp [base, off]
where
- off = StInt (i * sizeOf pk)
+ off = StInt (i * toInteger (sizeOf pk))
mangleIndexTree (StIndex pk base off)
= StPrim IntAddOp [
base,
let s = shift pk
- in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
- if s == 0 then off else StPrim SllOp [off, StInt s]
+ in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
]
where
- shift DoubleRep = 3::Integer
- shift CharRep = 0::Integer
- shift _ = IF_ARCH_alpha(3,2)
+ shift :: PrimRep -> Int
+ shift rep = case sizeOf rep of
+ 1 -> 0
+ 2 -> 1
+ 4 -> 2
+ 8 -> 3
+ other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
+ (int other)
\end{code}
\begin{code}
maybeImm :: StixTree -> Maybe Imm
-maybeImm (StLitLbl s) = Just (ImmLab s)
-maybeImm (StCLbl l) = Just (ImmCLbl l)
-
-maybeImm (StIndex rep (StCLbl l) (StInt off)) =
- Just (ImmIndex l (fromInteger (off * sizeOf rep)))
-
+maybeImm (StCLbl l)
+ = Just (ImmCLbl l)
+maybeImm (StIndex rep (StCLbl l) (StInt off))
+ = Just (ImmIndex l (fromInteger off * sizeOf rep))
maybeImm (StInt i)
- | i >= toInteger minInt && i <= toInteger maxInt
+ | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
= Just (ImmInt (fromInteger i))
| otherwise
= Just (ImmInteger i)
-- cannae be Nothing
getRegister (StReg (StixTemp u pk))
- = returnNat (Fixed pk (UnmappedReg u pk) nilOL)
+ = returnNat (Fixed pk (mkVReg u pk) nilOL)
getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
imm_lbl = ImmCLbl lbl
code dst = toOL [
- SEGMENT DataSegment,
+ SEGMENT RoDataSegment,
LABEL lbl,
ASCII True (_UNPK_ s),
SEGMENT TextSegment,
Double2FloatOp -> coerceFltCode x
Float2DoubleOp -> coerceFltCode x
- other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
+ other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
where
fn = case other_op of
FloatExpOp -> SLIT("exp")
AddrNeOp -> int_NE_code x y
AddrLtOp -> trivialCode (CMP ULT) x y
AddrLeOp -> trivialCode (CMP ULE) x y
-
+
FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
IntQuotOp -> trivialCode (DIV Q False) x y
IntRemOp -> trivialCode (REM Q False) x y
+ WordAddOp -> trivialCode (ADD Q False) x y
+ WordSubOp -> trivialCode (SUB Q False) x y
+ WordMulOp -> trivialCode (MUL Q False) x y
WordQuotOp -> trivialCode (DIV Q True) x y
WordRemOp -> trivialCode (REM Q True) x y
DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
+ AddrAddOp -> trivialCode (ADD Q False) x y
+ AddrSubOp -> trivialCode (SUB Q False) x y
+ AddrRemOp -> trivialCode (REM Q True) x y
+
AndOp -> trivialCode AND x y
OrOp -> trivialCode OR x y
XorOp -> trivialCode XOR x y
ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
- FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
- DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
+ FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
where
{- ------------------------------------------------------------
Some bizarre special code for getting condition codes into
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
+getRegister (StFloat f)
+ = getNatLabelNCG `thenNat` \ lbl ->
+ let code dst = toOL [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ DATA F [ImmFloat f],
+ SEGMENT TextSegment,
+ GLD F (ImmAddr (ImmCLbl lbl) 0) dst
+ ]
+ in
+ returnNat (Any FloatRep code)
+
+
getRegister (StDouble d)
| d == 0.0
= let code dst = unitOL (GLDZ dst)
- in trace "nativeGen: GLDZ"
- (returnNat (Any DoubleRep code))
+ in returnNat (Any DoubleRep code)
| d == 1.0
= let code dst = unitOL (GLD1 dst)
- in trace "nativeGen: GLD1"
- returnNat (Any DoubleRep code)
+ in returnNat (Any DoubleRep code)
| otherwise
= getNatLabelNCG `thenNat` \ lbl ->
= getDeltaNat `thenNat` \ current_stack_offset ->
let j = i+1 - (current_stack_offset `div` 4)
code dst
- = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst))
+ = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst))
in
returnNat (Any PtrRep code)
Int2DoubleOp -> coerceInt2FP DoubleRep x
other_op ->
- let
- fixed_x = if is_float_op -- promote to double
- then StPrim Float2DoubleOp [x]
- else x
- in
- getRegister (StCall fn cCallConv DoubleRep [x])
+ getRegister (StCall fn CCallConv DoubleRep [x])
where
(is_float_op, fn)
= case primop of
other
-> pprPanic "getRegister(x86,unary primop)"
- (pprStixTrees [StPrim primop [x]])
+ (pprStixTree (StPrim primop [x]))
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
DoubleLtOp -> condFltReg LTT x y
DoubleLeOp -> condFltReg LE x y
- IntAddOp -> add_code L x y
- IntSubOp -> sub_code L x y
- IntQuotOp -> quot_code L x y True{-division-}
- IntRemOp -> quot_code L x y False{-remainder-}
+ IntAddOp -> add_code L x y
+ IntSubOp -> sub_code L x y
+ IntQuotOp -> trivialCode (IQUOT L) Nothing x y
+ IntRemOp -> trivialCode (IREM L) Nothing x y
IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
+ WordAddOp -> add_code L x y
+ WordSubOp -> sub_code L x y
+ WordMulOp -> let op = IMUL L in trivialCode op (Just op) x y
+
FloatAddOp -> trivialFCode FloatRep GADD x y
FloatSubOp -> trivialFCode FloatRep GSUB x y
FloatMulOp -> trivialFCode FloatRep GMUL x y
DoubleMulOp -> trivialFCode DoubleRep GMUL x y
DoubleDivOp -> trivialFCode DoubleRep GDIV x y
+ AddrAddOp -> add_code L x y
+ AddrSubOp -> sub_code L x y
+ AddrRemOp -> trivialCode (IREM L) Nothing x y
+
AndOp -> let op = AND L in trivialCode op (Just op) x y
OrOp -> let op = OR L in trivialCode op (Just op) x y
XorOp -> let op = XOR L in trivialCode op (Just op) x y
ISraOp -> shift_code (SAR L) x y {-False-}
ISrlOp -> shift_code (SHR L) x y {-False-}
- FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
[promote x, promote y])
where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
[x, y])
other
-> pprPanic "getRegister(x86,dyadic primop)"
- (pprStixTrees [StPrim primop [x, y]])
+ (pprStixTree (StPrim primop [x, y]))
where
--------------------
sub_code sz x y = trivialCode (SUB sz) Nothing x y
- --------------------
- quot_code
- :: Size
- -> StixTree -> StixTree
- -> Bool -- True => division, False => remainder operation
- -> NatM Register
-
- -- x must go into eax, edx must be a sign-extension of eax, and y
- -- should go in some other register (or memory), so that we get
- -- edx:eax / reg -> eax (remainder in edx). Currently we choose
- -- to put y on the C stack, since that avoids tying up yet another
- -- precious register.
-
- quot_code sz x y is_division
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNCG IntRep `thenNat` \ tmp ->
- getDeltaNat `thenNat` \ delta ->
- let
- code1 = registerCode register1 tmp
- src1 = registerName register1 tmp
- code2 = registerCode register2 tmp
- src2 = registerName register2 tmp
- code__2 = code2 `snocOL` -- src2 := y
- PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y
- DELTA (delta-4) `appOL`
- code1 `snocOL` -- src1 := x
- MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x
- CLTD `snocOL`
- IDIV sz (OpAddr (spRel 0)) `snocOL`
- ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL`
- DELTA delta
- in
- returnNat (Fixed IntRep (if is_division then eax else edx) code__2)
- -----------------------
getRegister (StInd pk mem)
= getAmode mem `thenNat` \ amode ->
code__2 dst = code `snocOL`
if pk == DoubleRep || pk == FloatRep
then GLD size src dst
- else case size of
- L -> MOV L (OpAddr src) (OpReg dst)
- B -> MOVZxL B (OpAddr src) (OpReg dst)
+ else (case size of
+ B -> MOVSxL B
+ Bu -> MOVZxL Bu
+ W -> MOVSxL W
+ Wu -> MOVZxL Wu
+ L -> MOV L
+ Lu -> MOV L)
+ (OpAddr src) (OpReg dst)
in
returnNat (Any pk code__2)
in
returnNat (Any PtrRep code)
| otherwise
- = pprPanic "getRegister(x86)" (pprStixTrees [leaf])
+ = pprPanic "getRegister(x86)" (pprStixTree leaf)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
+getRegister (StFloat d)
+ = getNatLabelNCG `thenNat` \ lbl ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
+ let code dst = toOL [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ DATA F [ImmFloat d],
+ SEGMENT TextSegment,
+ SETHI (HI (ImmCLbl lbl)) tmp,
+ LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+ in
+ returnNat (Any FloatRep code)
+
getRegister (StDouble d)
= getNatLabelNCG `thenNat` \ lbl ->
getNewRegNCG PtrRep `thenNat` \ tmp ->
in
returnNat (Any DoubleRep code)
+-- The 6-word scratch area is immediately below the frame pointer.
+-- Below that is the spill area.
+getRegister (StScratchWord i)
+ | i >= 0 && i < 6
+ = let
+ code dst = unitOL (fpRelEA (i-6) dst)
+ in
+ returnNat (Any PtrRep code)
+
+
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
- IntNegOp -> trivialUCode (SUB False False g0) x
- NotOp -> trivialUCode (XNOR False g0) x
+ IntNegOp -> trivialUCode (SUB False False g0) x
+ NotOp -> trivialUCode (XNOR False g0) x
- FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
-
- DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
+ FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
+ DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
+ OrdOp -> coerceIntCode IntRep x
+ ChrOp -> chrCode x
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP FloatRep x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP DoubleRep x
+ Float2IntOp -> coerceFP2Int x
+ Int2FloatOp -> coerceInt2FP FloatRep x
+ Double2IntOp -> coerceFP2Int x
+ Int2DoubleOp -> coerceInt2FP DoubleRep x
other_op ->
let
- fixed_x = if is_float_op -- promote to double
- then StPrim Float2DoubleOp [x]
- else x
+ fixed_x = if is_float_op -- promote to double
+ then StPrim Float2DoubleOp [x]
+ else x
in
- getRegister (StCall fn cCallConv DoubleRep [x])
+ getRegister (StCall fn CCallConv DoubleRep [fixed_x])
where
(is_float_op, fn)
= case primop of
DoubleExpOp -> (False, SLIT("exp"))
DoubleLogOp -> (False, SLIT("log"))
- DoubleSqrtOp -> (True, SLIT("sqrt"))
+ DoubleSqrtOp -> (False, SLIT("sqrt"))
DoubleSinOp -> (False, SLIT("sin"))
DoubleCosOp -> (False, SLIT("cos"))
DoubleSinhOp -> (False, SLIT("sinh"))
DoubleCoshOp -> (False, SLIT("cosh"))
DoubleTanhOp -> (False, SLIT("tanh"))
- _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
+
+ other
+ -> pprPanic "getRegister(sparc,monadicprimop)"
+ (pprStixTree (StPrim primop [x]))
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
IntSubOp -> trivialCode (SUB False False) x y
-- ToDo: teach about V8+ SPARC mul/div instructions
- IntMulOp -> imul_div SLIT(".umul") x y
- IntQuotOp -> imul_div SLIT(".div") x y
- IntRemOp -> imul_div SLIT(".rem") x y
+ IntMulOp -> imul_div SLIT(".umul") x y
+ IntQuotOp -> imul_div SLIT(".div") x y
+ IntRemOp -> imul_div SLIT(".rem") x y
+
+ WordAddOp -> trivialCode (ADD False False) x y
+ WordSubOp -> trivialCode (SUB False False) x y
+ WordMulOp -> imul_div SLIT(".umul") x y
FloatAddOp -> trivialFCode FloatRep FADD x y
FloatSubOp -> trivialFCode FloatRep FSUB x y
DoubleMulOp -> trivialFCode DoubleRep FMUL x y
DoubleDivOp -> trivialFCode DoubleRep FDIV x y
+ AddrAddOp -> trivialCode (ADD False False) x y
+ AddrSubOp -> trivialCode (SUB False False) x y
+ AddrRemOp -> imul_div SLIT(".rem") x y
+
AndOp -> trivialCode (AND False) x y
OrOp -> trivialCode (OR False) x y
XorOp -> trivialCode (XOR False) x y
SllOp -> trivialCode SLL x y
SrlOp -> trivialCode SRL x y
- ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
- ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
- ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
+ ISllOp -> trivialCode SLL x y
+ ISraOp -> trivialCode SRA x y
+ ISrlOp -> trivialCode SRL x y
- FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
+ FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
+ [promote x, promote y])
where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
--- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
+ DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
+ [x, y])
+
+ other
+ -> pprPanic "getRegister(sparc,dyadic primop)"
+ (pprStixTree (StPrim primop [x, y]))
+
where
- imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
+ imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y])
getRegister (StInd pk mem)
= getAmode mem `thenNat` \ amode ->
OR False dst (RIImm (LO imm__2)) dst]
in
returnNat (Any PtrRep code)
+ | otherwise
+ = pprPanic "getRegister(sparc)" (pprStixTree leaf)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
- pk2 = registerRep register2
code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
c_dst = registerCode reg_dst tmp -- should be empty
r_dst = registerName reg_dst tmp
szs = primRepToSize pks
- opc = case szs of L -> MOV L ; B -> MOVZxL B
+ opc = case szs of
+ B -> MOVSxL B
+ Bu -> MOVZxL Bu
+ W -> MOVSxL W
+ Wu -> MOVZxL Wu
+ L -> MOV L
+ Lu -> MOV L
code | isNilOL c_dst
= c_addr `snocOL`
register allocator.
\begin{code}
-genJump :: StixTree{-the branch target-} -> NatM InstrBlock
+genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
#if alpha_TARGET_ARCH
target = ImmCLbl lbl
genJump tree
- = getRegister tree `thenNat` \ register ->
+ = getRegister tree `thenNat` \ register ->
getNewRegNCG PtrRep `thenNat` \ tmp ->
let
dst = registerName register pv
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-genJump (StInd pk mem)
+genJump dsts (StInd pk mem)
= getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
target = amodeAddr amode
in
- returnNat (code `snocOL` JMP (OpAddr target))
+ returnNat (code `snocOL` JMP dsts (OpAddr target))
-genJump tree
+genJump dsts tree
| maybeToBool imm
- = returnNat (unitOL (JMP (OpImm target)))
+ = returnNat (unitOL (JMP dsts (OpImm target)))
| otherwise
= getRegister tree `thenNat` \ register ->
code = registerCode register tmp
target = registerName register tmp
in
- returnNat (code `snocOL` JMP (OpReg target))
+ returnNat (code `snocOL` JMP dsts (OpReg target))
where
imm = maybeImm tree
target = case imm of Just x -> x
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
-genJump (StCLbl lbl)
- | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
- | otherwise = returnNat (toOL [CALL target 0 True, NOP])
+genJump dsts (StCLbl lbl)
+ | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
+ | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
+ | otherwise = returnNat (toOL [CALL target 0 True, NOP])
where
target = ImmCLbl lbl
-genJump tree
+genJump dsts tree
= getRegister tree `thenNat` \ register ->
getNewRegNCG PtrRep `thenNat` \ tmp ->
let
code = registerCode register tmp
target = registerName register tmp
in
- returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)
+ returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
#endif {- sparc_TARGET_ARCH -}
\end{code}
let
code = condCode condition
cond = condName condition
- target = ImmCLbl lbl
in
returnNat (code `snocOL` JXX cond lbl)
\begin{code}
genCCall
:: FAST_STRING -- function to call
- -> CallConv
+ -> CCallConv
-> PrimRep -- type of the result
-> [StixTree] -- arguments (of mixed type)
-> NatM InstrBlock
let (sizes, codes) = unzip sizes_n_codes
tot_arg_size = sum sizes
code2 = concatOL codes
- call = toOL [
- CALL fn__2,
- ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
- DELTA (delta + tot_arg_size)
- ]
+ call = toOL (
+ [CALL (fn__2 tot_arg_size)]
+ ++
+ -- Deallocate parameters after call for ccall;
+ -- but not for stdcall (callee does it)
+ (if cconv == StdCallConv then [] else
+ [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
+ ++
+
+ [DELTA (delta + tot_arg_size)]
+ )
in
setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
returnNat (code2 `appOL` call)
-- internally generated names like '.mul,' which don't get an
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
- fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (ptext fn)
- _ -> ImmLab (ptext fn)
+ fn_u = _UNPK_ fn
+ fn__2 tot_arg_size
+ | head fn_u == '.'
+ = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
+ | otherwise -- General case
+ = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
+
+ stdcallsize tot_arg_size
+ | cconv == StdCallConv = '@':show tot_arg_size
+ | otherwise = ""
arg_size DF = 8
- arg_size F = 8
+ arg_size F = 4
arg_size _ = 4
------------
if (case sz of DF -> True; F -> True; _ -> False)
then returnNat (size,
code `appOL`
- toOL [SUB L (OpImm (ImmInt 8)) (OpReg esp),
+ toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
DELTA (delta-size),
- GST DF reg (AddrBaseIndex (Just esp)
+ GST sz reg (AddrBaseIndex (Just esp)
Nothing
(ImmInt 0))]
)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
+{-
+ The SPARC calling convention is an absolute
+ nightmare. The first 6x32 bits of arguments are mapped into
+ %o0 through %o5, and the remaining arguments are dumped to the
+ stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
+
+ If we have to put args on the stack, move %o6==%sp down by
+ the number of words to go on the stack, to ensure there's enough space.
+
+ According to Fraser and Hanson's lcc book, page 478, fig 17.2,
+ 16 words above the stack pointer is a word for the address of
+ a structure return value. I use this as a temporary location
+ for moving values from float to int regs. Certainly it isn't
+ safe to put anything in the 16 words starting at %sp, since
+ this area can get trashed at any time due to window overflows
+ caused by signal handlers.
+
+ A final complication (if the above isn't enough) is that
+ we can't blithely calculate the arguments one by one into
+ %o0 .. %o5. Consider the following nested calls:
+
+ fff a (fff b c)
+
+ Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
+ the inner call will itself use %o0, which trashes the value put there
+ in preparation for the outer call. Upshot: we need to calculate the
+ args into temporary regs, and move those to arg regs or onto the
+ stack only immediately prior to the call proper. Sigh.
+-}
genCCall fn cconv kind args
- = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
- `thenNat` \ ((unused,_), argCode) ->
- let
- nRegs = length allArgRegs - length unused
- call = CALL fn__2 nRegs False
- code = concatOL argCode
- in
- returnNat (code `snocOL` call `snocOL` NOP)
+ = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
+ let (argcodes, vregss) = unzip argcode_and_vregs
+ argcode = concatOL argcodes
+ vregs = concat vregss
+ n_argRegs = length allArgRegs
+ n_argRegs_used = min (length vregs) n_argRegs
+ (move_sp_down, move_sp_up)
+ = let nn = length vregs - n_argRegs
+ + 1 -- (for the road)
+ in if nn <= 0
+ then (nilOL, nilOL)
+ else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
+ transfer_code
+ = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
+ call
+ = unitOL (CALL fn__2 n_argRegs_used False)
+ in
+ returnNat (argcode `appOL`
+ move_sp_down `appOL`
+ transfer_code `appOL`
+ call `appOL`
+ unitOL NOP `appOL`
+ move_sp_up)
where
- -- function names that begin with '.' are assumed to be special
- -- internally generated names like '.mul,' which don't get an
- -- underscore prefix
- -- ToDo:needed (WDP 96/03) ???
- fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (ptext fn)
- _ -> ImmLab (ptext fn)
-
- ------------------------------------
- {- Try to get a value into a specific register (or registers) for
- a call. The SPARC calling convention is an absolute
- nightmare. The first 6x32 bits of arguments are mapped into
- %o0 through %o5, and the remaining arguments are dumped to the
- stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
- first argument is a pair of the list of remaining argument
- registers to be assigned for this call and the next stack
- offset to use for overflowing arguments. This way,
- @get_arg@ can be applied to all of a call's arguments using
- @mapAccumL@.
- -}
- get_arg
- :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
- -> StixTree -- Current argument
- -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code
-
- -- We have to use up all of our argument registers first...
-
- get_arg (dst:dsts, offset) arg
- = getRegister arg `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- reg = if isFloatingRep pk then tmp else dst
- code = registerCode register reg
- src = registerName register reg
- pk = registerRep register
- in
- returnNat (
- case pk of
- DoubleRep ->
- case dsts of
- [] -> ( ([], offset + 1),
- code `snocOL`
- -- conveniently put the second part in the right stack
- -- location, and load the first part into %o5
- ST DF src (spRel (offset - 1)) `snocOL`
- LD W (spRel (offset - 1)) dst
- )
- (dst__2:dsts__2)
- -> ( (dsts__2, offset),
- code `snocOL`
- ST DF src (spRel (-2)) `snocOL`
- LD W (spRel (-2)) dst `snocOL`
- LD W (spRel (-1)) dst__2
- )
- FloatRep
- -> ( (dsts, offset),
- code `snocOL`
- ST F src (spRel (-2)) `snocOL`
- LD W (spRel (-2)) dst
- )
- _ -> ( (dsts, offset),
- if isFixed register
- then code `snocOL` OR False g0 (RIReg src) dst
- else code
- )
- )
- -- Once we have run out of argument registers, we move to the
- -- stack...
-
- get_arg ([], offset) arg
- = getRegister arg `thenNat` \ register ->
- getNewRegNCG (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerRep register
- sz = primRepToSize pk
- words = if pk == DoubleRep then 2 else 1
- in
- returnNat ( ([], offset + words),
- code `snocOL` ST sz src (spRel offset) )
-
+ -- function names that begin with '.' are assumed to be special
+ -- internally generated names like '.mul,' which don't get an
+ -- underscore prefix
+ -- ToDo:needed (WDP 96/03) ???
+ fn__2 = case (_HEAD_ fn) of
+ '.' -> ImmLit (ptext fn)
+ _ -> ImmLab False (ptext fn)
+
+ -- move args from the integer vregs into which they have been
+ -- marshalled, into %o0 .. %o5, and the rest onto the stack.
+ move_final :: [Reg] -> [Reg] -> Int -> [Instr]
+
+ move_final [] _ offset -- all args done
+ = []
+
+ move_final (v:vs) [] offset -- out of aregs; move to stack
+ = ST W v (spRel offset)
+ : move_final vs [] (offset+1)
+
+ move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
+ = OR False g0 (RIReg v) a
+ : move_final vs az offset
+
+ -- generate code to calculate an argument, and move it into one
+ -- or two integer vregs.
+ arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
+ arg_to_int_vregs arg
+ = getRegister arg `thenNat` \ register ->
+ getNewRegNCG (registerRep register) `thenNat` \ tmp ->
+ let code = registerCode register tmp
+ src = registerName register tmp
+ pk = registerRep register
+ in
+ -- the value is in src. Get it into 1 or 2 int vregs.
+ case pk of
+ DoubleRep ->
+ getNewRegNCG WordRep `thenNat` \ v1 ->
+ getNewRegNCG WordRep `thenNat` \ v2 ->
+ returnNat (
+ code `snocOL`
+ FMOV DF src f0 `snocOL`
+ ST F f0 (spRel 16) `snocOL`
+ LD W (spRel 16) v1 `snocOL`
+ ST F (fPair f0) (spRel 16) `snocOL`
+ LD W (spRel 16) v2
+ ,
+ [v1,v2]
+ )
+ FloatRep ->
+ getNewRegNCG WordRep `thenNat` \ v1 ->
+ returnNat (
+ code `snocOL`
+ ST F src (spRel 16) `snocOL`
+ LD W (spRel 16) v1
+ ,
+ [v1]
+ )
+ other ->
+ getNewRegNCG WordRep `thenNat` \ v1 ->
+ returnNat (
+ code `snocOL` OR False g0 (RIReg src) v1
+ ,
+ [v1]
+ )
#endif {- sparc_TARGET_ARCH -}
\end{code}
code2 `snocOL`
instr (primRepToSize pk) tmp1 src2 dst
in
- returnNat (Any DoubleRep code__2)
+ returnNat (Any pk code__2)
-------------
%* *
%************************************************************************
-Integer to character conversion. Where applicable, we try to do this
-in one step if the original object is in memory.
+Integer to character conversion.
\begin{code}
chrCode :: StixTree -> NatM Register
#if alpha_TARGET_ARCH
+-- TODO: This is probably wrong, but I don't know Alpha assembler.
+-- It should coerce a 64-bit value to a 32-bit value.
+
chrCode x
= getRegister x `thenNat` \ register ->
getNewRegNCG IntRep `thenNat` \ reg ->
chrCode x
= getRegister x `thenNat` \ register ->
- let
- code__2 dst = let
- code = registerCode register dst
- src = registerName register dst
- in code `appOL`
- if isFixed register && src /= dst
- then toOL [MOV L (OpReg src) (OpReg dst),
- AND L (OpImm (ImmInt 255)) (OpReg dst)]
- else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src))
- in
- returnNat (Any IntRep code__2)
+ returnNat (
+ case register of
+ Fixed _ reg code -> Fixed IntRep reg code
+ Any _ code -> Any IntRep code
+ )
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
-chrCode (StInd pk mem)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- src_off = addrOffset src 3
- src__2 = case src_off of Just x -> x
- code__2 dst = if maybeToBool src_off then
- code `snocOL` LD BU src__2 dst
- else
- code `snocOL`
- LD (primRepToSize pk) src dst `snocOL`
- AND False dst (RIImm (ImmInt 255)) dst
- in
- returnNat (Any pk code__2)
-
chrCode x
= getRegister x `thenNat` \ register ->
- getNewRegNCG IntRep `thenNat` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst
- in
- returnNat (Any IntRep code__2)
+ returnNat (
+ case register of
+ Fixed _ reg code -> Fixed IntRep reg code
+ Any _ code -> Any IntRep code
+ )
#endif {- sparc_TARGET_ARCH -}
\end{code}
projects / ghc-hetmet.git / blobdiff