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"
snocOL, consOL, concatOL )
import AbsCUtils ( magicIdPrimRep )
import CallConv ( CallConv )
-import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )
+import CLabel ( isAsmTemp, CLabel, labelDynamic )
import Maybes ( maybeToBool, expectJust )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
-import CallConv ( cCallConv )
+import CallConv ( cCallConv, stdCallConv )
import Stix ( getNatLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..),
DestInfo, hasDestInfo,
- pprStixTree, ppStixReg,
+ pprStixTree,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
getDeltaNat, setDeltaNat
Code extractor for an entire stix tree---stix statement level.
\begin{code}
-stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock
+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]
+
-stmt2Instrs stmt = case stmt of
+stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock
+stmtToInstrs stmt = case stmt of
StComment s -> returnNat (unitOL (COMMENT s))
StSegment seg -> returnNat (unitOL (SEGMENT seg))
`consOL` concatOL codes)
where
getData :: StixTree -> NatM (InstrBlock, Imm)
-
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) =
- getNatLabelNCG `thenNat` \ lbl ->
- returnNat (toOL [LABEL lbl,
- ASCII True (_UNPK_ s)],
- ImmCLbl lbl)
+ 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
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 = 2::Integer
- shift Int8Rep = 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 (StCLbl l)
= Just (ImmCLbl l)
maybeImm (StIndex rep (StCLbl l) (StInt off))
- = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
+ = Just (ImmIndex l (fromInteger off * sizeOf rep))
maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt
= Just (ImmInt (fromInteger i))
imm_lbl = ImmCLbl lbl
code dst = toOL [
- SEGMENT DataSegment,
+ SEGMENT RoDataSegment,
LABEL lbl,
ASCII True (_UNPK_ s),
SEGMENT TextSegment,
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
= 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)
Double2IntOp -> coerceFP2Int x
Int2DoubleOp -> coerceInt2FP DoubleRep x
+ IntToInt8Op -> extendIntCode Int8Rep IntRep x
+ IntToInt16Op -> extendIntCode Int16Rep IntRep x
+ IntToInt32Op -> getRegister x
+ WordToWord8Op -> extendIntCode Word8Rep WordRep x
+ WordToWord16Op -> extendIntCode Word16Rep WordRep x
+ WordToWord32Op -> getRegister x
+
other_op ->
getRegister (StCall fn cCallConv DoubleRep [x])
where
DoubleLtOp -> condFltReg LTT x y
DoubleLeOp -> condFltReg LE x y
- IntAddOp -> add_code L x y
- IntSubOp -> sub_code L x y
+ 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
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)
-- Below that is the spill area.
getRegister (StScratchWord i)
| i >= 0 && i < 6
- = let j = i+1
- code dst = unitOL (fpRelEA j dst)
+ = let
+ code dst = unitOL (fpRelEA (i-6) dst)
in
returnNat (Any PtrRep code)
FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
- DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
-
Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
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
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])
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`
let
code = condCode condition
cond = condName condition
- target = ImmCLbl lbl
in
returnNat (code `snocOL` JXX cond lbl)
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)]
+ ++
+ (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 False (ptext fn)
+ fn_u = _UNPK_ fn
+ fn__2 tot_arg_size
+ | head fn_u == '.'
+ = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
+ | otherwise
+ = 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 = 4
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
+extendIntCode :: PrimRep -> PrimRep -> StixTree -> NatM Register
+extendIntCode pks pkd x
+ = coerceIntCode pks x `thenNat` \ register ->
+ getNewRegNCG pks `thenNat` \ reg ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+ opc = case pkd of IntRep -> MOVSxL ; WordRep -> MOVZxL
+ sz = primRepToSize pks
+ code__2 dst = code `snocOL` opc sz (OpReg src) (OpReg dst)
+ in
+ returnNat (Any pkd code__2)
+
+------------
coerceInt2FP pk x
= getRegister x `thenNat` \ register ->
getNewRegNCG IntRep `thenNat` \ reg ->
projects / ghc-hetmet.git / blobdiff