%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.40 2001/11/23 11:58:00 simonmar Exp $
+% $Id: AbsCSyn.lhs,v 1.41 2001/12/05 17:35:12 sewardj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
import Literal ( mkMachInt, Literal(..) )
import ForeignCall ( CCallSpec )
import PrimRep ( PrimRep(..) )
+import MachOp ( MachOp(..) )
import Unique ( Unique )
import StgSyn ( StgOp )
import TyCon ( TyCon )
import BitSet -- for liveness masks
+import Maybes ( Maybe012(..) )
import FastTypes
+import Outputable
\end{code}
@AbstractC@ is a list of Abstract~C statements, but the data structure
-- CReg CurCostCentre or CC_HDR(R1.p{-Node-})
Int -- size of closure, for profiling
+ -- NEW CASES FOR EXPANDED PRIMOPS
+
+ | CMachOpStmt -- Machine-level operation
+ (Maybe012 CAddrMode) -- 0, 1 or 2 results
+ MachOp
+ [CAddrMode] -- Arguments
+ (Maybe [MagicId]) -- list of regs which need to be preserved
+ -- across the primop. This is allowed to be Nothing only if
+ -- machOpIsDefinitelyInline returns True. And that in turn may
+ -- only return True if we are absolutely sure that the mach op
+ -- can be done inline on all platforms.
+
+ | CSequential -- Do the nested AbstractCs sequentially.
+ [AbstractC] -- In particular, as far as the AbsCUtils.doSimultaneously
+ -- is concerned, these stmts are to be treated as atomic
+ -- and are not to be reordered.
+
+ -- end of NEW CASES FOR EXPANDED PRIMOPS
+
| COpStmt
[CAddrMode] -- Results
StgOp
!PrimRep -- the kind of the result
CExprMacro -- the macro to generate a value
[CAddrMode] -- and its arguments
+
+ | CMem PrimRep -- A value :: PrimRep, in memory, at the
+ CAddrMode -- specified address
\end{code}
Various C macros for values which are dependent on the back-end layout.
mixedTypeLocn, mixedPtrLocn,
flattenAbsC,
mkAbsCStmtList
-
-- printing/forcing stuff comes from PprAbsC
) where
#include "HsVersions.h"
import AbsCSyn
+import CLabel ( mkMAP_FROZEN_infoLabel )
import Digraph ( stronglyConnComp, SCC(..) )
import DataCon ( fIRST_TAG, ConTag )
-import Literal ( literalPrimRep, mkMachWord )
+import Literal ( literalPrimRep, mkMachWord, mkMachInt )
import PrimRep ( getPrimRepSize, PrimRep(..) )
+import PrimOp ( PrimOp(..) )
+import MachOp ( MachOp(..), isDefinitelyInlineMachOp )
import Unique ( Unique{-instance Eq-} )
import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import CmdLineOpts ( opt_EmitCExternDecls )
-import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget, isCasmTarget )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety(..),
+ isDynamicTarget, isCasmTarget, defaultCCallConv )
import StgSyn ( StgOp(..) )
+import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
+import Constants ( wORD_SIZE )
+import Maybes ( Maybe012(..) )
+import Outputable
import Panic ( panic )
import FastTypes
-import Maybe ( isJust )
+import Maybe ( isJust, maybeToList )
infixr 9 `thenFlt`
\end{code}
getAmodeRep (CLit lit) = literalPrimRep lit
getAmodeRep (CMacroExpr kind _ _) = kind
getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
+getAmodeRep (CMem rep addr) = rep
\end{code}
@mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
returnFlt ( (tag, alt_heres), alt_tops )
flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
- | is_dynamic -- Emit a typedef if its a dynamic call
- || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
+ | is_dynamic -- Emit a typedef if its a dynamic call
+ || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
= returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
where
is_dynamic = isDynamicTarget target
flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CInitHdr a b cc _) = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(COpStmt results op args vol_regs) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CInitHdr a b cc sz) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(CMachOpStmt res mop args m_vols) = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs)
+ = returnFlt (stmt, AbsCNop)
+flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
+ = dscCOpStmt (filter non_void_amode results) op
+ (filter non_void_amode args) vol_regs
+ `thenFlt` \ simpl ->
+ case simpl of
+ COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt" -- make sure we don't loop!
+ other -> flatAbsC other
+ {-
+ A gruesome hack for printing the names of inline primops when they
+ are used.
+ oink other
+ where
+ oink xxx
+ = getUniqFlt `thenFlt` \ uu ->
+ flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx])
+
+ moo uu op_str
+ = COpStmt
+ []
+ (StgFCallOp
+ (CCall (CCallSpec (CasmTarget (_PK_ (mktxt op_str)))
+ defaultCCallConv PlaySafe))
+ uu
+ )
+ [CReg VoidReg]
+ []
+ mktxt op_str
+ = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); "
+ -}
+
+flatAbsC (CSequential abcs)
+ = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) ->
+ returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops)
+
-- Some statements only make sense at the top level, so we always float
-- them. This probably isn't necessary.
= or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
\end{code}
-
@conflictsWith@ tells whether an assignment to its first argument will
screw up an access to its second.
rr other1 other2 = False
\end{code}
+
+%************************************************************************
+%* *
+\subsection[flat-primops]{Translating COpStmts to CMachOpStmts}
+%* *
+%************************************************************************
+
+\begin{code}
+
+
+------------------------------------------------------------------------------
+
+-- Assumes no volatiles
+mkHalfWord_HIADDR res arg
+# if WORDS_BIGENDIAN
+ = CMachOpStmt (Just1 res) MO_Nat_And [arg, CLit (mkMachWord halfword_mask)] Nothing
+# else
+ = CMachOpStmt (Just1 res) MO_Nat_Shr [arg, CLit (mkMachWord halfword_shift)] Nothing
+# endif
+ where
+ (halfword_mask, halfword_shift)
+ | wORD_SIZE == 4 = (65535, 16)
+ | wORD_SIZE == 8 = (4294967295::Integer, 32)
+
+
+mkTemp :: PrimRep -> FlatM CAddrMode
+mkTemp rep
+ = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep)
+
+mkTemps = mapFlt mkTemp
+
+mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
+mkDerefOff rep base off
+ | off == 0 -- optimisation
+ = CMem rep base
+ | otherwise
+ = CMem rep (CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep))
+
+mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
+mkNoDerefOff rep base off
+ = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
+
+-- Sigh. This is done in 3 seperate places. Should be
+-- commoned up (here, in pprAbsC of COpStmt, and presumably
+-- somewhere in the NCG).
+non_void_amode amode
+ = case getAmodeRep amode of
+ VoidRep -> False
+ k -> True
+
+doIndexOffForeignObjOp rep res addr idx
+ = Just (Just1 res, MO_ReadOSBI fixedHdrSize rep, [addr,idx])
+
+doIndexOffAddrOp rep res addr idx
+ = Just (Just1 res, MO_ReadOSBI 0 rep, [addr,idx])
+
+doIndexByteArrayOp rep res addr idx
+ = Just (Just1 res, MO_ReadOSBI arrWordsHdrSize rep, [addr,idx])
+
+doWriteOffAddrOp rep addr idx val
+ = Just (Just0, MO_WriteOSBI 0 rep, [addr,idx,val])
+
+doWriteByteArrayOp rep addr idx val
+ = Just (Just0, MO_WriteOSBI arrWordsHdrSize rep, [addr,idx,val])
+
+-- Simple dyadic op but one for which we need to cast first arg to
+-- be sure of correctness
+translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
+ = mkTemp cast_arg1_to `thenFlt` \ arg1casted ->
+ (returnFlt . CSequential) [
+ CAssign arg1casted arg1,
+ CMachOpStmt (Just1 res) mop [arg1casted,arg2]
+ (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
+ ]
+
+------------------------------------------------------------------------------
+
+dscCOpStmt :: [CAddrMode] -- Results
+ -> PrimOp
+ -> [CAddrMode] -- Arguments
+ -> [MagicId] -- Potentially volatile/live registers
+ -- (to save/restore around the op)
+ -> FlatM AbstractC
+
+-- #define parzh(r,node) r = 1
+dscCOpStmt [res] ParOp [arg] vols
+ = returnFlt
+ (CAssign res (CLit (mkMachInt 1)))
+
+-- #define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var)
+dscCOpStmt [res] ReadMutVarOp [mutv] vols
+ = returnFlt
+ (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
+
+-- #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
+dscCOpStmt [] WriteMutVarOp [mutv,var] vols
+ = returnFlt
+ (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
+
+
+-- #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
+-- #define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo)
+dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
+ = returnFlt
+ (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
+
+-- #define writeForeignObjzh(res,datum) \
+-- (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
+dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
+ = returnFlt
+ (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
+
+
+-- #define sizzeofByteArrayzh(r,a) \
+-- r = (((StgArrWords *)(a))->words * sizeof(W_))
+dscCOpStmt [res] SizeofByteArrayOp [arg] vols
+ = mkTemp WordRep `thenFlt` \ w ->
+ (returnFlt . CSequential) [
+ CAssign w (mkDerefOff WordRep arg fixedHdrSize),
+ CMachOpStmt (Just1 w)
+ MO_NatU_Mul [w, CLit (mkMachInt (toInteger wORD_SIZE))] (Just vols),
+ CAssign res w
+ ]
+
+-- #define sizzeofMutableByteArrayzh(r,a) \
+-- r = (((StgArrWords *)(a))->words * sizeof(W_))
+dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols
+ = dscCOpStmt [res] SizeofByteArrayOp [arg] vols
+
+
+-- #define touchzh(o) /* nothing */
+dscCOpStmt [] TouchOp [arg] vols
+ = returnFlt AbsCNop
+
+-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
+dscCOpStmt [res] ByteArrayContents_Char [arg] vols
+ = mkTemp PtrRep `thenFlt` \ ptr ->
+ (returnFlt . CSequential) [
+ CMachOpStmt (Just1 ptr) MO_NatU_to_NatP [arg] Nothing,
+ CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize),
+ CAssign res ptr
+ ]
+
+-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
+dscCOpStmt [res] StableNameToIntOp [arg] vols
+ = returnFlt
+ (CAssign res (mkDerefOff WordRep arg fixedHdrSize))
+
+-- #define eqStableNamezh(r,sn1,sn2) \
+-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
+dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols
+ = mkTemps [WordRep, WordRep] `thenFlt` \ [sn1,sn2] ->
+ (returnFlt . CSequential) [
+ CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize),
+ CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize),
+ CMachOpStmt (Just1 res) MO_Nat_Eq [sn1,sn2] Nothing
+ ]
+
+-- #define addrToHValuezh(r,a) r=(P_)a
+dscCOpStmt [res] AddrToHValueOp [arg] vols
+ = returnFlt
+ (CAssign res arg)
+
+-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
+dscCOpStmt [res] DataToTagOp [arg] vols
+ = mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] ->
+ (returnFlt . CSequential) [
+ CAssign t_infoptr (mkDerefOff PtrRep arg 0),
+ CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
+ mkHalfWord_HIADDR res t_theword
+ ]
+
+
+{- Freezing arrays-of-ptrs requires changing an info table, for the
+ benefit of the generational collector. It needs to scavenge mutable
+ objects, even if they are in old space. When they become immutable,
+ they can be removed from this scavenge list. -}
+
+-- #define unsafeFreezzeArrayzh(r,a) \
+-- { \
+-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); \
+-- r = a; \
+-- }
+dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
+ = (returnFlt . CSequential) [
+ CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
+ CAssign res arg
+ ]
+
+-- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
+dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
+ = returnFlt
+ (CAssign res arg)
+
+-- This ought to be trivial, but it's difficult to insert the casts
+-- required to keep the C compiler happy.
+dscCOpStmt [r] AddrRemOp [a1,a2] vols
+ = mkTemp WordRep `thenFlt` \ a1casted ->
+ (returnFlt . CSequential) [
+ CMachOpStmt (Just1 a1casted) MO_NatP_to_NatU [a1] Nothing,
+ CMachOpStmt (Just1 r) MO_NatU_Rem [a1casted,a2] Nothing
+ ]
+
+-- not handled by translateOp because they need casts
+dscCOpStmt [r] SllOp [a1,a2] vols
+ = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
+dscCOpStmt [r] SrlOp [a1,a2] vols
+ = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
+
+dscCOpStmt [r] ISllOp [a1,a2] vols
+ = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
+dscCOpStmt [r] ISrlOp [a1,a2] vols
+ = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
+dscCOpStmt [r] ISraOp [a1,a2] vols
+ = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
+
+
+-- Handle all others as simply as possible.
+dscCOpStmt ress op args vols
+ = case translateOp ress op args of
+ Nothing
+ -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
+ Just (maybe_res, mop, args)
+ -> returnFlt (
+ CMachOpStmt maybe_res mop args
+ (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
+ )
+
+
+
+translateOp [r] ReadArrayOp [obj,ix]
+ = Just (Just1 r, MO_ReadOSBI arrPtrsHdrSize PtrRep, [obj,ix])
+translateOp [r] IndexArrayOp [obj,ix]
+ = Just (Just1 r, MO_ReadOSBI arrPtrsHdrSize PtrRep, [obj,ix])
+translateOp [] WriteArrayOp [obj,ix,v]
+ = Just (Just0, MO_WriteOSBI arrPtrsHdrSize PtrRep, [obj,ix,v])
+
+-- IndexXXXoffForeignObj
+
+translateOp [r] IndexOffForeignObjOp_Char [a,i] = doIndexOffForeignObjOp Word8Rep r a i
+translateOp [r] IndexOffForeignObjOp_WideChar [a,i] = doIndexOffForeignObjOp Word32Rep r a i
+translateOp [r] IndexOffForeignObjOp_Int [a,i] = doIndexOffForeignObjOp IntRep r a i
+translateOp [r] IndexOffForeignObjOp_Word [a,i] = doIndexOffForeignObjOp WordRep r a i
+translateOp [r] IndexOffForeignObjOp_Addr [a,i] = doIndexOffForeignObjOp AddrRep r a i
+translateOp [r] IndexOffForeignObjOp_Float [a,i] = doIndexOffForeignObjOp FloatRep r a i
+translateOp [r] IndexOffForeignObjOp_Double [a,i] = doIndexOffForeignObjOp DoubleRep r a i
+translateOp [r] IndexOffForeignObjOp_StablePtr [a,i] = doIndexOffForeignObjOp StablePtrRep r a i
+
+translateOp [r] IndexOffForeignObjOp_Int8 [a,i] = doIndexOffForeignObjOp Int8Rep r a i
+translateOp [r] IndexOffForeignObjOp_Int16 [a,i] = doIndexOffForeignObjOp Int16Rep r a i
+translateOp [r] IndexOffForeignObjOp_Int32 [a,i] = doIndexOffForeignObjOp Int32Rep r a i
+translateOp [r] IndexOffForeignObjOp_Int64 [a,i] = doIndexOffForeignObjOp Int64Rep r a i
+
+translateOp [r] IndexOffForeignObjOp_Word8 [a,i] = doIndexOffForeignObjOp Word8Rep r a i
+translateOp [r] IndexOffForeignObjOp_Word16 [a,i] = doIndexOffForeignObjOp Word16Rep r a i
+translateOp [r] IndexOffForeignObjOp_Word32 [a,i] = doIndexOffForeignObjOp Word32Rep r a i
+translateOp [r] IndexOffForeignObjOp_Word64 [a,i] = doIndexOffForeignObjOp Word64Rep r a i
+
+-- IndexXXXoffAddr
+
+translateOp [r] IndexOffAddrOp_Char [a,i] = doIndexOffAddrOp Word8Rep r a i
+translateOp [r] IndexOffAddrOp_WideChar [a,i] = doIndexOffAddrOp Word32Rep r a i
+translateOp [r] IndexOffAddrOp_Int [a,i] = doIndexOffAddrOp IntRep r a i
+translateOp [r] IndexOffAddrOp_Word [a,i] = doIndexOffAddrOp WordRep r a i
+translateOp [r] IndexOffAddrOp_Addr [a,i] = doIndexOffAddrOp AddrRep r a i
+translateOp [r] IndexOffAddrOp_Float [a,i] = doIndexOffAddrOp FloatRep r a i
+translateOp [r] IndexOffAddrOp_Double [a,i] = doIndexOffAddrOp DoubleRep r a i
+translateOp [r] IndexOffAddrOp_StablePtr [a,i] = doIndexOffAddrOp StablePtrRep r a i
+
+translateOp [r] IndexOffAddrOp_Int8 [a,i] = doIndexOffAddrOp Int8Rep r a i
+translateOp [r] IndexOffAddrOp_Int16 [a,i] = doIndexOffAddrOp Int16Rep r a i
+translateOp [r] IndexOffAddrOp_Int32 [a,i] = doIndexOffAddrOp Int32Rep r a i
+translateOp [r] IndexOffAddrOp_Int64 [a,i] = doIndexOffAddrOp Int64Rep r a i
+
+translateOp [r] IndexOffAddrOp_Word8 [a,i] = doIndexOffAddrOp Word8Rep r a i
+translateOp [r] IndexOffAddrOp_Word16 [a,i] = doIndexOffAddrOp Word16Rep r a i
+translateOp [r] IndexOffAddrOp_Word32 [a,i] = doIndexOffAddrOp Word32Rep r a i
+translateOp [r] IndexOffAddrOp_Word64 [a,i] = doIndexOffAddrOp Word64Rep r a i
+
+-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
+
+translateOp [r] ReadOffAddrOp_Char [a,i] = doIndexOffAddrOp Word8Rep r a i
+translateOp [r] ReadOffAddrOp_WideChar [a,i] = doIndexOffAddrOp Word32Rep r a i
+translateOp [r] ReadOffAddrOp_Int [a,i] = doIndexOffAddrOp IntRep r a i
+translateOp [r] ReadOffAddrOp_Word [a,i] = doIndexOffAddrOp WordRep r a i
+translateOp [r] ReadOffAddrOp_Addr [a,i] = doIndexOffAddrOp AddrRep r a i
+translateOp [r] ReadOffAddrOp_Float [a,i] = doIndexOffAddrOp FloatRep r a i
+translateOp [r] ReadOffAddrOp_Double [a,i] = doIndexOffAddrOp DoubleRep r a i
+translateOp [r] ReadOffAddrOp_StablePtr [a,i] = doIndexOffAddrOp StablePtrRep r a i
+
+translateOp [r] ReadOffAddrOp_Int8 [a,i] = doIndexOffAddrOp Int8Rep r a i
+translateOp [r] ReadOffAddrOp_Int16 [a,i] = doIndexOffAddrOp Int16Rep r a i
+translateOp [r] ReadOffAddrOp_Int32 [a,i] = doIndexOffAddrOp Int32Rep r a i
+translateOp [r] ReadOffAddrOp_Int64 [a,i] = doIndexOffAddrOp Int64Rep r a i
+
+translateOp [r] ReadOffAddrOp_Word8 [a,i] = doIndexOffAddrOp Word8Rep r a i
+translateOp [r] ReadOffAddrOp_Word16 [a,i] = doIndexOffAddrOp Word16Rep r a i
+translateOp [r] ReadOffAddrOp_Word32 [a,i] = doIndexOffAddrOp Word32Rep r a i
+translateOp [r] ReadOffAddrOp_Word64 [a,i] = doIndexOffAddrOp Word64Rep r a i
+
+-- WriteXXXoffAddr
+
+translateOp [] WriteOffAddrOp_Char [a,i,x] = doWriteOffAddrOp Word8Rep a i x
+translateOp [] WriteOffAddrOp_WideChar [a,i,x] = doWriteOffAddrOp Word32Rep a i x
+translateOp [] WriteOffAddrOp_Int [a,i,x] = doWriteOffAddrOp IntRep a i x
+translateOp [] WriteOffAddrOp_Word [a,i,x] = doWriteOffAddrOp WordRep a i x
+translateOp [] WriteOffAddrOp_Addr [a,i,x] = doWriteOffAddrOp AddrRep a i x
+translateOp [] WriteOffAddrOp_Float [a,i,x] = doWriteOffAddrOp FloatRep a i x
+translateOp [] WriteOffAddrOp_ForeignObj [a,i,x] = doWriteOffAddrOp ForeignObjRep a i x
+translateOp [] WriteOffAddrOp_Double [a,i,x] = doWriteOffAddrOp DoubleRep a i x
+translateOp [] WriteOffAddrOp_StablePtr [a,i,x] = doWriteOffAddrOp StablePtrRep a i x
+
+translateOp [] WriteOffAddrOp_Int8 [a,i,x] = doWriteOffAddrOp Int8Rep a i x
+translateOp [] WriteOffAddrOp_Int16 [a,i,x] = doWriteOffAddrOp Int16Rep a i x
+translateOp [] WriteOffAddrOp_Int32 [a,i,x] = doWriteOffAddrOp Int32Rep a i x
+translateOp [] WriteOffAddrOp_Int64 [a,i,x] = doWriteOffAddrOp Int64Rep a i x
+
+translateOp [] WriteOffAddrOp_Word8 [a,i,x] = doWriteOffAddrOp Word8Rep a i x
+translateOp [] WriteOffAddrOp_Word16 [a,i,x] = doWriteOffAddrOp Word16Rep a i x
+translateOp [] WriteOffAddrOp_Word32 [a,i,x] = doWriteOffAddrOp Word32Rep a i x
+translateOp [] WriteOffAddrOp_Word64 [a,i,x] = doWriteOffAddrOp Word64Rep a i x
+
+-- IndexXXXArray
+
+translateOp [r] IndexByteArrayOp_Char [a,i] = doIndexByteArrayOp Word8Rep r a i
+translateOp [r] IndexByteArrayOp_WideChar [a,i] = doIndexByteArrayOp Word32Rep r a i
+translateOp [r] IndexByteArrayOp_Int [a,i] = doIndexByteArrayOp IntRep r a i
+translateOp [r] IndexByteArrayOp_Word [a,i] = doIndexByteArrayOp WordRep r a i
+translateOp [r] IndexByteArrayOp_Addr [a,i] = doIndexByteArrayOp AddrRep r a i
+translateOp [r] IndexByteArrayOp_Float [a,i] = doIndexByteArrayOp FloatRep r a i
+translateOp [r] IndexByteArrayOp_Double [a,i] = doIndexByteArrayOp DoubleRep r a i
+translateOp [r] IndexByteArrayOp_StablePtr [a,i] = doIndexByteArrayOp StablePtrRep r a i
+
+translateOp [r] IndexByteArrayOp_Int8 [a,i] = doIndexByteArrayOp Int8Rep r a i
+translateOp [r] IndexByteArrayOp_Int16 [a,i] = doIndexByteArrayOp Int16Rep r a i
+translateOp [r] IndexByteArrayOp_Int32 [a,i] = doIndexByteArrayOp Int32Rep r a i
+translateOp [r] IndexByteArrayOp_Int64 [a,i] = doIndexByteArrayOp Int64Rep r a i
+
+translateOp [r] IndexByteArrayOp_Word8 [a,i] = doIndexByteArrayOp Word8Rep r a i
+translateOp [r] IndexByteArrayOp_Word16 [a,i] = doIndexByteArrayOp Word16Rep r a i
+translateOp [r] IndexByteArrayOp_Word32 [a,i] = doIndexByteArrayOp Word32Rep r a i
+translateOp [r] IndexByteArrayOp_Word64 [a,i] = doIndexByteArrayOp Word64Rep r a i
+
+-- ReadXXXArray, identical to IndexXXXArray.
+
+translateOp [r] ReadByteArrayOp_Char [a,i] = doIndexByteArrayOp Word8Rep r a i
+translateOp [r] ReadByteArrayOp_WideChar [a,i] = doIndexByteArrayOp Word32Rep r a i
+translateOp [r] ReadByteArrayOp_Int [a,i] = doIndexByteArrayOp IntRep r a i
+translateOp [r] ReadByteArrayOp_Word [a,i] = doIndexByteArrayOp WordRep r a i
+translateOp [r] ReadByteArrayOp_Addr [a,i] = doIndexByteArrayOp AddrRep r a i
+translateOp [r] ReadByteArrayOp_Float [a,i] = doIndexByteArrayOp FloatRep r a i
+translateOp [r] ReadByteArrayOp_Double [a,i] = doIndexByteArrayOp DoubleRep r a i
+translateOp [r] ReadByteArrayOp_StablePtr [a,i] = doIndexByteArrayOp StablePtrRep r a i
+
+translateOp [r] ReadByteArrayOp_Int8 [a,i] = doIndexByteArrayOp Int8Rep r a i
+translateOp [r] ReadByteArrayOp_Int16 [a,i] = doIndexByteArrayOp Int16Rep r a i
+translateOp [r] ReadByteArrayOp_Int32 [a,i] = doIndexByteArrayOp Int32Rep r a i
+translateOp [r] ReadByteArrayOp_Int64 [a,i] = doIndexByteArrayOp Int64Rep r a i
+
+translateOp [r] ReadByteArrayOp_Word8 [a,i] = doIndexByteArrayOp Word8Rep r a i
+translateOp [r] ReadByteArrayOp_Word16 [a,i] = doIndexByteArrayOp Word16Rep r a i
+translateOp [r] ReadByteArrayOp_Word32 [a,i] = doIndexByteArrayOp Word32Rep r a i
+translateOp [r] ReadByteArrayOp_Word64 [a,i] = doIndexByteArrayOp Word64Rep r a i
+
+-- WriteXXXArray
+
+translateOp [] WriteByteArrayOp_Char [a,i,x] = doWriteByteArrayOp Word8Rep a i x
+translateOp [] WriteByteArrayOp_WideChar [a,i,x] = doWriteByteArrayOp Word32Rep a i x
+translateOp [] WriteByteArrayOp_Int [a,i,x] = doWriteByteArrayOp IntRep a i x
+translateOp [] WriteByteArrayOp_Word [a,i,x] = doWriteByteArrayOp WordRep a i x
+translateOp [] WriteByteArrayOp_Addr [a,i,x] = doWriteByteArrayOp AddrRep a i x
+translateOp [] WriteByteArrayOp_Float [a,i,x] = doWriteByteArrayOp FloatRep a i x
+translateOp [] WriteByteArrayOp_Double [a,i,x] = doWriteByteArrayOp DoubleRep a i x
+translateOp [] WriteByteArrayOp_StablePtr [a,i,x] = doWriteByteArrayOp StablePtrRep a i x
+
+translateOp [] WriteByteArrayOp_Int8 [a,i,x] = doWriteByteArrayOp Int8Rep a i x
+translateOp [] WriteByteArrayOp_Int16 [a,i,x] = doWriteByteArrayOp Int16Rep a i x
+translateOp [] WriteByteArrayOp_Int32 [a,i,x] = doWriteByteArrayOp Int32Rep a i x
+translateOp [] WriteByteArrayOp_Int64 [a,i,x] = doWriteByteArrayOp Int64Rep a i x
+
+translateOp [] WriteByteArrayOp_Word8 [a,i,x] = doWriteByteArrayOp Word8Rep a i x
+translateOp [] WriteByteArrayOp_Word16 [a,i,x] = doWriteByteArrayOp Word16Rep a i x
+translateOp [] WriteByteArrayOp_Word32 [a,i,x] = doWriteByteArrayOp Word32Rep a i x
+translateOp [] WriteByteArrayOp_Word64 [a,i,x] = doWriteByteArrayOp Word64Rep a i x
+
+-- Native word signless ops
+
+translateOp [r] IntAddOp [a1,a2] = Just (Just1 r, MO_Nat_Add, [a1,a2])
+translateOp [r] IntSubOp [a1,a2] = Just (Just1 r, MO_Nat_Sub, [a1,a2])
+translateOp [r] WordAddOp [a1,a2] = Just (Just1 r, MO_Nat_Add, [a1,a2])
+translateOp [r] WordSubOp [a1,a2] = Just (Just1 r, MO_Nat_Sub, [a1,a2])
+translateOp [r] AddrAddOp [a1,a2] = Just (Just1 r, MO_Nat_Add, [a1,a2])
+translateOp [r] AddrSubOp [a1,a2] = Just (Just1 r, MO_Nat_Sub, [a1,a2])
+
+translateOp [r] IntEqOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2])
+translateOp [r] IntNeOp [a1,a2] = Just (Just1 r, MO_Nat_Ne, [a1,a2])
+translateOp [r] WordEqOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2])
+translateOp [r] WordNeOp [a1,a2] = Just (Just1 r, MO_Nat_Ne, [a1,a2])
+translateOp [r] AddrEqOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2])
+translateOp [r] AddrNeOp [a1,a2] = Just (Just1 r, MO_Nat_Ne, [a1,a2])
+
+translateOp [r] AndOp [a1,a2] = Just (Just1 r, MO_Nat_And, [a1,a2])
+translateOp [r] OrOp [a1,a2] = Just (Just1 r, MO_Nat_Or, [a1,a2])
+translateOp [r] XorOp [a1,a2] = Just (Just1 r, MO_Nat_Xor, [a1,a2])
+translateOp [r] NotOp [a1] = Just (Just1 r, MO_Nat_Not, [a1])
+
+-- Native word signed ops
+
+translateOp [r] IntMulOp [a1,a2] = Just (Just1 r, MO_NatS_Mul, [a1,a2])
+translateOp [r] IntQuotOp [a1,a2] = Just (Just1 r, MO_NatS_Quot, [a1,a2])
+translateOp [r] IntRemOp [a1,a2] = Just (Just1 r, MO_NatS_Rem, [a1,a2])
+translateOp [r] IntNegOp [a1] = Just (Just1 r, MO_NatS_Neg, [a1])
+
+translateOp [r,c] IntAddCOp [a1,a2] = Just (Just2 r c, MO_NatS_AddC, [a1,a2])
+translateOp [r,c] IntSubCOp [a1,a2] = Just (Just2 r c, MO_NatS_SubC, [a1,a2])
+translateOp [r,c] IntMulCOp [a1,a2] = Just (Just2 r c, MO_NatS_MulC, [a1,a2])
+
+translateOp [r] IntGeOp [a1,a2] = Just (Just1 r, MO_NatS_Ge, [a1,a2])
+translateOp [r] IntLeOp [a1,a2] = Just (Just1 r, MO_NatS_Le, [a1,a2])
+translateOp [r] IntGtOp [a1,a2] = Just (Just1 r, MO_NatS_Gt, [a1,a2])
+translateOp [r] IntLtOp [a1,a2] = Just (Just1 r, MO_NatS_Lt, [a1,a2])
+
+-- Native word unsigned ops
+
+translateOp [r] WordGeOp [a1,a2] = Just (Just1 r, MO_NatU_Ge, [a1,a2])
+translateOp [r] WordLeOp [a1,a2] = Just (Just1 r, MO_NatU_Le, [a1,a2])
+translateOp [r] WordGtOp [a1,a2] = Just (Just1 r, MO_NatU_Gt, [a1,a2])
+translateOp [r] WordLtOp [a1,a2] = Just (Just1 r, MO_NatU_Lt, [a1,a2])
+
+translateOp [r] WordMulOp [a1,a2] = Just (Just1 r, MO_NatU_Mul, [a1,a2])
+translateOp [r] WordQuotOp [a1,a2] = Just (Just1 r, MO_NatU_Quot, [a1,a2])
+translateOp [r] WordRemOp [a1,a2] = Just (Just1 r, MO_NatU_Rem, [a1,a2])
+
+translateOp [r] AddrGeOp [a1,a2] = Just (Just1 r, MO_NatU_Ge, [a1,a2])
+translateOp [r] AddrLeOp [a1,a2] = Just (Just1 r, MO_NatU_Le, [a1,a2])
+translateOp [r] AddrGtOp [a1,a2] = Just (Just1 r, MO_NatU_Gt, [a1,a2])
+translateOp [r] AddrLtOp [a1,a2] = Just (Just1 r, MO_NatU_Lt, [a1,a2])
+
+-- 32-bit unsigned ops
+
+translateOp [r] CharEqOp [a1,a2] = Just (Just1 r, MO_32U_Eq, [a1,a2])
+translateOp [r] CharNeOp [a1,a2] = Just (Just1 r, MO_32U_Ne, [a1,a2])
+translateOp [r] CharGeOp [a1,a2] = Just (Just1 r, MO_32U_Ge, [a1,a2])
+translateOp [r] CharLeOp [a1,a2] = Just (Just1 r, MO_32U_Le, [a1,a2])
+translateOp [r] CharGtOp [a1,a2] = Just (Just1 r, MO_32U_Gt, [a1,a2])
+translateOp [r] CharLtOp [a1,a2] = Just (Just1 r, MO_32U_Lt, [a1,a2])
+
+-- Double ops
+
+translateOp [r] DoubleEqOp [a1,a2] = Just (Just1 r, MO_Dbl_Eq, [a1,a2])
+translateOp [r] DoubleNeOp [a1,a2] = Just (Just1 r, MO_Dbl_Ne, [a1,a2])
+translateOp [r] DoubleGeOp [a1,a2] = Just (Just1 r, MO_Dbl_Ge, [a1,a2])
+translateOp [r] DoubleLeOp [a1,a2] = Just (Just1 r, MO_Dbl_Le, [a1,a2])
+translateOp [r] DoubleGtOp [a1,a2] = Just (Just1 r, MO_Dbl_Gt, [a1,a2])
+translateOp [r] DoubleLtOp [a1,a2] = Just (Just1 r, MO_Dbl_Lt, [a1,a2])
+
+translateOp [r] DoubleAddOp [a1,a2] = Just (Just1 r, MO_Dbl_Add, [a1,a2])
+translateOp [r] DoubleSubOp [a1,a2] = Just (Just1 r, MO_Dbl_Sub, [a1,a2])
+translateOp [r] DoubleMulOp [a1,a2] = Just (Just1 r, MO_Dbl_Mul, [a1,a2])
+translateOp [r] DoubleDivOp [a1,a2] = Just (Just1 r, MO_Dbl_Div, [a1,a2])
+translateOp [r] DoublePowerOp [a1,a2] = Just (Just1 r, MO_Dbl_Pwr, [a1,a2])
+
+translateOp [r] DoubleSinOp [a1] = Just (Just1 r, MO_Dbl_Sin, [a1])
+translateOp [r] DoubleCosOp [a1] = Just (Just1 r, MO_Dbl_Cos, [a1])
+translateOp [r] DoubleTanOp [a1] = Just (Just1 r, MO_Dbl_Tan, [a1])
+translateOp [r] DoubleSinhOp [a1] = Just (Just1 r, MO_Dbl_Sinh, [a1])
+translateOp [r] DoubleCoshOp [a1] = Just (Just1 r, MO_Dbl_Cosh, [a1])
+translateOp [r] DoubleTanhOp [a1] = Just (Just1 r, MO_Dbl_Tanh, [a1])
+translateOp [r] DoubleAsinOp [a1] = Just (Just1 r, MO_Dbl_Asin, [a1])
+translateOp [r] DoubleAcosOp [a1] = Just (Just1 r, MO_Dbl_Acos, [a1])
+translateOp [r] DoubleAtanOp [a1] = Just (Just1 r, MO_Dbl_Atan, [a1])
+translateOp [r] DoubleLogOp [a1] = Just (Just1 r, MO_Dbl_Log, [a1])
+translateOp [r] DoubleExpOp [a1] = Just (Just1 r, MO_Dbl_Exp, [a1])
+translateOp [r] DoubleSqrtOp [a1] = Just (Just1 r, MO_Dbl_Sqrt, [a1])
+translateOp [r] DoubleNegOp [a1] = Just (Just1 r, MO_Dbl_Neg, [a1])
+
+-- Float ops
+
+translateOp [r] FloatEqOp [a1,a2] = Just (Just1 r, MO_Flt_Eq, [a1,a2])
+translateOp [r] FloatNeOp [a1,a2] = Just (Just1 r, MO_Flt_Ne, [a1,a2])
+translateOp [r] FloatGeOp [a1,a2] = Just (Just1 r, MO_Flt_Ge, [a1,a2])
+translateOp [r] FloatLeOp [a1,a2] = Just (Just1 r, MO_Flt_Le, [a1,a2])
+translateOp [r] FloatGtOp [a1,a2] = Just (Just1 r, MO_Flt_Gt, [a1,a2])
+translateOp [r] FloatLtOp [a1,a2] = Just (Just1 r, MO_Flt_Lt, [a1,a2])
+
+translateOp [r] FloatAddOp [a1,a2] = Just (Just1 r, MO_Flt_Add, [a1,a2])
+translateOp [r] FloatSubOp [a1,a2] = Just (Just1 r, MO_Flt_Sub, [a1,a2])
+translateOp [r] FloatMulOp [a1,a2] = Just (Just1 r, MO_Flt_Mul, [a1,a2])
+translateOp [r] FloatDivOp [a1,a2] = Just (Just1 r, MO_Flt_Div, [a1,a2])
+translateOp [r] FloatPowerOp [a1,a2] = Just (Just1 r, MO_Flt_Pwr, [a1,a2])
+
+translateOp [r] FloatSinOp [a1] = Just (Just1 r, MO_Flt_Sin, [a1])
+translateOp [r] FloatCosOp [a1] = Just (Just1 r, MO_Flt_Cos, [a1])
+translateOp [r] FloatTanOp [a1] = Just (Just1 r, MO_Flt_Tan, [a1])
+translateOp [r] FloatSinhOp [a1] = Just (Just1 r, MO_Flt_Sinh, [a1])
+translateOp [r] FloatCoshOp [a1] = Just (Just1 r, MO_Flt_Cosh, [a1])
+translateOp [r] FloatTanhOp [a1] = Just (Just1 r, MO_Flt_Tanh, [a1])
+translateOp [r] FloatAsinOp [a1] = Just (Just1 r, MO_Flt_Asin, [a1])
+translateOp [r] FloatAcosOp [a1] = Just (Just1 r, MO_Flt_Acos, [a1])
+translateOp [r] FloatAtanOp [a1] = Just (Just1 r, MO_Flt_Atan, [a1])
+translateOp [r] FloatLogOp [a1] = Just (Just1 r, MO_Flt_Log, [a1])
+translateOp [r] FloatExpOp [a1] = Just (Just1 r, MO_Flt_Exp, [a1])
+translateOp [r] FloatSqrtOp [a1] = Just (Just1 r, MO_Flt_Sqrt, [a1])
+translateOp [r] FloatNegOp [a1] = Just (Just1 r, MO_Flt_Neg, [a1])
+
+-- Conversions
+
+translateOp [r] Int2DoubleOp [a1] = Just (Just1 r, MO_NatS_to_Dbl, [a1])
+translateOp [r] Double2IntOp [a1] = Just (Just1 r, MO_Dbl_to_NatS, [a1])
+
+translateOp [r] Int2FloatOp [a1] = Just (Just1 r, MO_NatS_to_Flt, [a1])
+translateOp [r] Float2IntOp [a1] = Just (Just1 r, MO_Flt_to_NatS, [a1])
+
+translateOp [r] Float2DoubleOp [a1] = Just (Just1 r, MO_Flt_to_Dbl, [a1])
+translateOp [r] Double2FloatOp [a1] = Just (Just1 r, MO_Dbl_to_Flt, [a1])
+
+translateOp [r] Int2WordOp [a1] = Just (Just1 r, MO_NatS_to_NatU, [a1])
+translateOp [r] Word2IntOp [a1] = Just (Just1 r, MO_NatU_to_NatS, [a1])
+
+translateOp [r] Int2AddrOp [a1] = Just (Just1 r, MO_NatS_to_NatP, [a1])
+translateOp [r] Addr2IntOp [a1] = Just (Just1 r, MO_NatP_to_NatS, [a1])
+
+translateOp [r] OrdOp [a1] = Just (Just1 r, MO_32U_to_NatS, [a1])
+translateOp [r] ChrOp [a1] = Just (Just1 r, MO_NatS_to_32U, [a1])
+
+translateOp [r] Narrow8IntOp [a1] = Just (Just1 r, MO_8S_to_NatS, [a1])
+translateOp [r] Narrow16IntOp [a1] = Just (Just1 r, MO_16S_to_NatS, [a1])
+translateOp [r] Narrow32IntOp [a1] = Just (Just1 r, MO_32S_to_NatS, [a1])
+
+translateOp [r] Narrow8WordOp [a1] = Just (Just1 r, MO_8U_to_NatU, [a1])
+translateOp [r] Narrow16WordOp [a1] = Just (Just1 r, MO_16U_to_NatU, [a1])
+translateOp [r] Narrow32WordOp [a1] = Just (Just1 r, MO_32U_to_NatU, [a1])
+
+translateOp [r] SameMutVarOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2])
+translateOp [r] SameMVarOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2])
+translateOp [r] SameMutableArrayOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2])
+translateOp [r] SameMutableByteArrayOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2])
+translateOp [r] EqForeignObj [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2])
+translateOp [r] EqStablePtrOp [a1,a2] = Just (Just1 r, MO_Nat_Eq, [a1,a2])
+
+translateOp _ _ _ = Nothing
+
+\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CLabel.lhs,v 1.48 2001/11/08 12:56:01 simonmar Exp $
+% $Id: CLabel.lhs,v 1.49 2001/12/05 17:35:12 sewardj Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType
labelType (RtsLabel RtsUpdInfo) = InfoTblType
+labelType (RtsLabel (Rts_Info _)) = InfoTblType
labelType (CaseLabel _ CaseReturnInfo) = InfoTblType
labelType (CaseLabel _ CaseReturnPt) = CodeType
labelType (CaseLabel _ CaseVecTbl) = VecTblType
--- /dev/null
+
+module MachOp ( MachOp(..), pprMachOp,
+ isDefinitelyInlineMachOp,
+ isCommutableMachOp,
+ isComparisonMachOp,
+ resultRepsOfMachOp
+ )
+where
+
+#include "HsVersions.h"
+
+import PrimRep ( PrimRep(..) )
+import Maybes ( Maybe012(..) )
+import Outputable
+
+
+{- Machine-level primops; ones which we can reasonably delegate to the
+ native code generators to handle. Basically contains C's primops
+ and no others.
+
+ Nomenclature: all ops indicate width and signedness, where
+ appropriate. Widths: 8/16/32/64 means the given size, obviously.
+ Nat means the native word size. Signedness: S means signed, U
+ means unsigned. For operations where signedness is irrelevant or
+ makes no difference (for example integer add), the signedness
+ component is omitted.
+
+ An exception: NatP is a ptr-typed native word. From the point of
+ view of the native code generators this distinction is irrelevant,
+ but the C code generator sometimes needs this info to emit the
+ right casts.
+-}
+
+data MachOp
+
+ -- OPS at the native word size
+ = MO_Nat_Add -- +
+ | MO_Nat_Sub -- -
+ | MO_Nat_Eq
+ | MO_Nat_Ne
+
+ | MO_NatS_Ge
+ | MO_NatS_Le
+ | MO_NatS_Gt
+ | MO_NatS_Lt
+
+ | MO_NatU_Ge
+ | MO_NatU_Le
+ | MO_NatU_Gt
+ | MO_NatU_Lt
+
+ | MO_NatS_Mul -- signed *
+ | MO_NatS_Quot -- signed / (same semantics as IntQuotOp)
+ | MO_NatS_Rem -- signed % (same semantics as IntRemOp)
+ | MO_NatS_Neg -- unary -
+
+ | MO_NatU_Mul -- unsigned *
+ | MO_NatU_Quot -- unsigned / (same semantics as WordQuotOp)
+ | MO_NatU_Rem -- unsigned % (same semantics as WordRemOp)
+
+ | MO_NatS_AddC -- signed +, first result sum, second result carry
+ | MO_NatS_SubC -- signed -, first result sum, second result borrow
+ | MO_NatS_MulC -- signed *, first result sum, second result carry
+
+ | MO_Nat_And
+ | MO_Nat_Or
+ | MO_Nat_Xor
+ | MO_Nat_Not
+ | MO_Nat_Shl
+ | MO_Nat_Shr
+ | MO_Nat_Sar
+
+ -- OPS at 32 bits regardless of word size
+ | MO_32U_Eq
+ | MO_32U_Ne
+ | MO_32U_Ge
+ | MO_32U_Le
+ | MO_32U_Gt
+ | MO_32U_Lt
+
+ -- IEEE754 Double ops
+ | MO_Dbl_Eq
+ | MO_Dbl_Ne
+ | MO_Dbl_Ge
+ | MO_Dbl_Le
+ | MO_Dbl_Gt
+ | MO_Dbl_Lt
+
+ | MO_Dbl_Add
+ | MO_Dbl_Sub
+ | MO_Dbl_Mul
+ | MO_Dbl_Div
+ | MO_Dbl_Pwr
+
+ | MO_Dbl_Sin
+ | MO_Dbl_Cos
+ | MO_Dbl_Tan
+ | MO_Dbl_Sinh
+ | MO_Dbl_Cosh
+ | MO_Dbl_Tanh
+ | MO_Dbl_Asin
+ | MO_Dbl_Acos
+ | MO_Dbl_Atan
+ | MO_Dbl_Log
+ | MO_Dbl_Exp
+ | MO_Dbl_Sqrt
+ | MO_Dbl_Neg
+
+ -- IEEE754 Float ops
+ | MO_Flt_Add
+ | MO_Flt_Sub
+ | MO_Flt_Mul
+ | MO_Flt_Div
+ | MO_Flt_Pwr
+
+ | MO_Flt_Eq
+ | MO_Flt_Ne
+ | MO_Flt_Ge
+ | MO_Flt_Le
+ | MO_Flt_Gt
+ | MO_Flt_Lt
+
+ | MO_Flt_Sin
+ | MO_Flt_Cos
+ | MO_Flt_Tan
+ | MO_Flt_Sinh
+ | MO_Flt_Cosh
+ | MO_Flt_Tanh
+ | MO_Flt_Asin
+ | MO_Flt_Acos
+ | MO_Flt_Atan
+ | MO_Flt_Log
+ | MO_Flt_Exp
+ | MO_Flt_Neg
+ | MO_Flt_Sqrt
+
+ -- Conversions. Some of these are NOPs, in which case they
+ -- are here usually to placate the C code generator.
+ | MO_32U_to_NatS
+ | MO_NatS_to_32U
+
+ | MO_NatS_to_Dbl
+ | MO_Dbl_to_NatS
+
+ | MO_NatS_to_Flt
+ | MO_Flt_to_NatS
+
+ | MO_NatS_to_NatU
+ | MO_NatU_to_NatS
+
+ | MO_NatS_to_NatP
+ | MO_NatP_to_NatS
+ | MO_NatU_to_NatP
+ | MO_NatP_to_NatU
+
+ | MO_Dbl_to_Flt
+ | MO_Flt_to_Dbl
+
+ | MO_8S_to_NatS
+ | MO_16S_to_NatS
+ | MO_32S_to_NatS
+ | MO_8U_to_NatU
+ | MO_16U_to_NatU
+ | MO_32U_to_NatU
+
+ -- Reading/writing arrays
+ | MO_ReadOSBI Int PrimRep -- [base_ptr, index_value]
+ | MO_WriteOSBI Int PrimRep -- [base_ptr, index_value, value_to_write]
+ -- Read/write a value :: the PrimRep
+ -- at byte address
+ -- sizeof(machine_word)*Int + base_ptr + sizeof(PrimRep)*index_value
+ deriving Eq
+
+
+
+-- Almost, but not quite == text . derived show
+pprMachOp :: MachOp -> SDoc
+
+pprMachOp MO_Nat_Add = text "MO_Nat_Add"
+pprMachOp MO_Nat_Sub = text "MO_Nat_Sub"
+pprMachOp MO_Nat_Eq = text "MO_Nat_Eq"
+pprMachOp MO_Nat_Ne = text "MO_Nat_Ne"
+
+pprMachOp MO_NatS_Ge = text "MO_NatS_Ge"
+pprMachOp MO_NatS_Le = text "MO_NatS_Le"
+pprMachOp MO_NatS_Gt = text "MO_NatS_Gt"
+pprMachOp MO_NatS_Lt = text "MO_NatS_Lt"
+
+pprMachOp MO_NatU_Ge = text "MO_NatU_Ge"
+pprMachOp MO_NatU_Le = text "MO_NatU_Le"
+pprMachOp MO_NatU_Gt = text "MO_NatU_Gt"
+pprMachOp MO_NatU_Lt = text "MO_NatU_Lt"
+
+pprMachOp MO_NatS_Mul = text "MO_NatS_Mul"
+pprMachOp MO_NatS_Quot = text "MO_NatS_Quot"
+pprMachOp MO_NatS_Rem = text "MO_NatS_Rem"
+pprMachOp MO_NatS_Neg = text "MO_NatS_Neg"
+
+pprMachOp MO_NatU_Mul = text "MO_NatU_Mul"
+pprMachOp MO_NatU_Quot = text "MO_NatU_Quot"
+pprMachOp MO_NatU_Rem = text "MO_NatU_Rem"
+
+pprMachOp MO_NatS_AddC = text "MO_NatS_AddC"
+pprMachOp MO_NatS_SubC = text "MO_NatS_SubC"
+pprMachOp MO_NatS_MulC = text "MO_NatS_MulC"
+
+pprMachOp MO_Nat_And = text "MO_Nat_And"
+pprMachOp MO_Nat_Or = text "MO_Nat_Or"
+pprMachOp MO_Nat_Xor = text "MO_Nat_Xor"
+pprMachOp MO_Nat_Not = text "MO_Nat_Not"
+pprMachOp MO_Nat_Shl = text "MO_Nat_Shl"
+pprMachOp MO_Nat_Shr = text "MO_Nat_Shr"
+pprMachOp MO_Nat_Sar = text "MO_Nat_Sar"
+
+pprMachOp MO_32U_Eq = text "MO_32U_Eq"
+pprMachOp MO_32U_Ne = text "MO_32U_Ne"
+pprMachOp MO_32U_Ge = text "MO_32U_Ge"
+pprMachOp MO_32U_Le = text "MO_32U_Le"
+pprMachOp MO_32U_Gt = text "MO_32U_Gt"
+pprMachOp MO_32U_Lt = text "MO_32U_Lt"
+
+pprMachOp MO_Dbl_Eq = text "MO_Dbl_Eq"
+pprMachOp MO_Dbl_Ne = text "MO_Dbl_Ne"
+pprMachOp MO_Dbl_Ge = text "MO_Dbl_Ge"
+pprMachOp MO_Dbl_Le = text "MO_Dbl_Le"
+pprMachOp MO_Dbl_Gt = text "MO_Dbl_Gt"
+pprMachOp MO_Dbl_Lt = text "MO_Dbl_Lt"
+
+pprMachOp MO_Dbl_Add = text "MO_Dbl_Add"
+pprMachOp MO_Dbl_Sub = text "MO_Dbl_Sub"
+pprMachOp MO_Dbl_Mul = text "MO_Dbl_Mul"
+pprMachOp MO_Dbl_Div = text "MO_Dbl_Div"
+pprMachOp MO_Dbl_Pwr = text "MO_Dbl_Pwr"
+
+pprMachOp MO_Dbl_Sin = text "MO_Dbl_Sin"
+pprMachOp MO_Dbl_Cos = text "MO_Dbl_Cos"
+pprMachOp MO_Dbl_Tan = text "MO_Dbl_Tan"
+pprMachOp MO_Dbl_Sinh = text "MO_Dbl_Sinh"
+pprMachOp MO_Dbl_Cosh = text "MO_Dbl_Cosh"
+pprMachOp MO_Dbl_Tanh = text "MO_Dbl_Tanh"
+pprMachOp MO_Dbl_Asin = text "MO_Dbl_Asin"
+pprMachOp MO_Dbl_Acos = text "MO_Dbl_Acos"
+pprMachOp MO_Dbl_Atan = text "MO_Dbl_Atan"
+pprMachOp MO_Dbl_Log = text "MO_Dbl_Log"
+pprMachOp MO_Dbl_Exp = text "MO_Dbl_Exp"
+pprMachOp MO_Dbl_Sqrt = text "MO_Dbl_Sqrt"
+pprMachOp MO_Dbl_Neg = text "MO_Dbl_Neg"
+
+pprMachOp MO_Flt_Add = text "MO_Flt_Add"
+pprMachOp MO_Flt_Sub = text "MO_Flt_Sub"
+pprMachOp MO_Flt_Mul = text "MO_Flt_Mul"
+pprMachOp MO_Flt_Div = text "MO_Flt_Div"
+pprMachOp MO_Flt_Pwr = text "MO_Flt_Pwr"
+
+pprMachOp MO_Flt_Eq = text "MO_Flt_Eq"
+pprMachOp MO_Flt_Ne = text "MO_Flt_Ne"
+pprMachOp MO_Flt_Ge = text "MO_Flt_Ge"
+pprMachOp MO_Flt_Le = text "MO_Flt_Le"
+pprMachOp MO_Flt_Gt = text "MO_Flt_Gt"
+pprMachOp MO_Flt_Lt = text "MO_Flt_Lt"
+
+pprMachOp MO_Flt_Sin = text "MO_Flt_Sin"
+pprMachOp MO_Flt_Cos = text "MO_Flt_Cos"
+pprMachOp MO_Flt_Tan = text "MO_Flt_Tan"
+pprMachOp MO_Flt_Sinh = text "MO_Flt_Sinh"
+pprMachOp MO_Flt_Cosh = text "MO_Flt_Cosh"
+pprMachOp MO_Flt_Tanh = text "MO_Flt_Tanh"
+pprMachOp MO_Flt_Asin = text "MO_Flt_Asin"
+pprMachOp MO_Flt_Acos = text "MO_Flt_Acos"
+pprMachOp MO_Flt_Atan = text "MO_Flt_Atan"
+pprMachOp MO_Flt_Log = text "MO_Flt_Log"
+pprMachOp MO_Flt_Exp = text "MO_Flt_Exp"
+pprMachOp MO_Flt_Sqrt = text "MO_Flt_Sqrt"
+pprMachOp MO_Flt_Neg = text "MO_Flt_Neg"
+
+pprMachOp MO_32U_to_NatS = text "MO_32U_to_NatS"
+pprMachOp MO_NatS_to_32U = text "MO_NatS_to_32U"
+
+pprMachOp MO_NatS_to_Dbl = text "MO_NatS_to_Dbl"
+pprMachOp MO_Dbl_to_NatS = text "MO_Dbl_to_NatS"
+
+pprMachOp MO_NatS_to_Flt = text "MO_NatS_to_Flt"
+pprMachOp MO_Flt_to_NatS = text "MO_Flt_to_NatS"
+
+pprMachOp MO_NatS_to_NatU = text "MO_NatS_to_NatU"
+pprMachOp MO_NatU_to_NatS = text "MO_NatU_to_NatS"
+
+pprMachOp MO_NatS_to_NatP = text "MO_NatS_to_NatP"
+pprMachOp MO_NatP_to_NatS = text "MO_NatP_to_NatS"
+pprMachOp MO_NatU_to_NatP = text "MO_NatU_to_NatP"
+pprMachOp MO_NatP_to_NatU = text "MO_NatP_to_NatU"
+
+pprMachOp MO_Dbl_to_Flt = text "MO_Dbl_to_Flt"
+pprMachOp MO_Flt_to_Dbl = text "MO_Flt_to_Dbl"
+
+pprMachOp MO_8S_to_NatS = text "MO_8S_to_NatS"
+pprMachOp MO_16S_to_NatS = text "MO_16S_to_NatS"
+pprMachOp MO_32S_to_NatS = text "MO_32S_to_NatS"
+
+pprMachOp MO_8U_to_NatU = text "MO_8U_to_NatU"
+pprMachOp MO_16U_to_NatU = text "MO_16U_to_NatU"
+pprMachOp MO_32U_to_NatU = text "MO_32U_to_NatU"
+
+pprMachOp (MO_ReadOSBI offset rep)
+ = text "MO_ReadOSBI" <> parens (int offset <> comma <> ppr rep)
+pprMachOp (MO_WriteOSBI offset rep)
+ = text "MO_WriteOSBI" <> parens (int offset <> comma <> ppr rep)
+
+
+
+-- Non-exported helper enumeration:
+data MO_Prop
+ = MO_Commutable
+ | MO_DefinitelyInline
+ | MO_Comparison
+ deriving Eq
+
+comm = MO_Commutable
+inline = MO_DefinitelyInline
+comp = MO_Comparison
+
+
+-- If in doubt, return False. This generates worse code on the
+-- via-C route, but has no effect on the native code routes.
+-- Remember that claims about definitely inline have to be true
+-- regardless of what the C compiler does, so we need to be
+-- careful about boundary cases like sqrt which are sometimes
+-- implemented in software and sometimes in hardware.
+isDefinitelyInlineMachOp :: MachOp -> Bool
+isDefinitelyInlineMachOp mop = inline `elem` snd (machOpProps mop)
+
+-- If in doubt, return False. This generates worse code on the
+-- native routes, but is otherwise harmless.
+isCommutableMachOp :: MachOp -> Bool
+isCommutableMachOp mop = comm `elem` snd (machOpProps mop)
+
+-- If in doubt, return False. This generates worse code on the
+-- native routes, but is otherwise harmless.
+isComparisonMachOp :: MachOp -> Bool
+isComparisonMachOp mop = comp `elem` snd (machOpProps mop)
+
+-- Find the PrimReps for the returned value(s) of the MachOp.
+resultRepsOfMachOp :: MachOp -> Maybe012 PrimRep
+resultRepsOfMachOp mop = fst (machOpProps mop)
+
+-- This bit does the real work.
+machOpProps :: MachOp -> (Maybe012 PrimRep, [MO_Prop])
+
+machOpProps MO_Nat_Add = (Just1 IntRep, [inline, comm])
+machOpProps MO_Nat_Sub = (Just1 IntRep, [inline])
+machOpProps MO_Nat_Eq = (Just1 IntRep, [inline, comp, comm])
+machOpProps MO_Nat_Ne = (Just1 IntRep, [inline, comp, comm])
+
+machOpProps MO_NatS_Ge = (Just1 IntRep, [inline, comp])
+machOpProps MO_NatS_Le = (Just1 IntRep, [inline, comp])
+machOpProps MO_NatS_Gt = (Just1 IntRep, [inline, comp])
+machOpProps MO_NatS_Lt = (Just1 IntRep, [inline, comp])
+
+machOpProps MO_NatU_Ge = (Just1 IntRep, [inline, comp])
+machOpProps MO_NatU_Le = (Just1 IntRep, [inline, comp])
+machOpProps MO_NatU_Gt = (Just1 IntRep, [inline, comp])
+machOpProps MO_NatU_Lt = (Just1 IntRep, [inline, comp])
+
+machOpProps MO_NatS_Mul = (Just1 IntRep, [inline, comm])
+machOpProps MO_NatS_Quot = (Just1 IntRep, [inline])
+machOpProps MO_NatS_Rem = (Just1 IntRep, [inline])
+machOpProps MO_NatS_Neg = (Just1 IntRep, [inline])
+
+machOpProps MO_NatU_Mul = (Just1 WordRep, [inline, comm])
+machOpProps MO_NatU_Quot = (Just1 WordRep, [inline])
+machOpProps MO_NatU_Rem = (Just1 WordRep, [inline])
+
+machOpProps MO_NatS_AddC = (Just2 IntRep IntRep, [])
+machOpProps MO_NatS_SubC = (Just2 IntRep IntRep, [])
+machOpProps MO_NatS_MulC = (Just2 IntRep IntRep, [])
+
+machOpProps MO_Nat_And = (Just1 IntRep, [inline, comm])
+machOpProps MO_Nat_Or = (Just1 IntRep, [inline, comm])
+machOpProps MO_Nat_Xor = (Just1 IntRep, [inline, comm])
+machOpProps MO_Nat_Not = (Just1 IntRep, [inline])
+machOpProps MO_Nat_Shl = (Just1 IntRep, [inline])
+machOpProps MO_Nat_Shr = (Just1 IntRep, [inline])
+machOpProps MO_Nat_Sar = (Just1 IntRep, [inline])
+
+machOpProps MO_32U_Eq = (Just1 IntRep, [inline, comp, comm])
+machOpProps MO_32U_Ne = (Just1 IntRep, [inline, comp, comm])
+machOpProps MO_32U_Ge = (Just1 IntRep, [inline, comp])
+machOpProps MO_32U_Le = (Just1 IntRep, [inline, comp])
+machOpProps MO_32U_Gt = (Just1 IntRep, [inline, comp])
+machOpProps MO_32U_Lt = (Just1 IntRep, [inline, comp])
+
+machOpProps MO_Dbl_Eq = (Just1 IntRep, [inline, comp, comm])
+machOpProps MO_Dbl_Ne = (Just1 IntRep, [inline, comp, comm])
+machOpProps MO_Dbl_Ge = (Just1 IntRep, [inline, comp])
+machOpProps MO_Dbl_Le = (Just1 IntRep, [inline, comp])
+machOpProps MO_Dbl_Gt = (Just1 IntRep, [inline, comp])
+machOpProps MO_Dbl_Lt = (Just1 IntRep, [inline, comp])
+
+machOpProps MO_Dbl_Add = (Just1 DoubleRep, [inline, comm])
+machOpProps MO_Dbl_Sub = (Just1 DoubleRep, [inline])
+machOpProps MO_Dbl_Mul = (Just1 DoubleRep, [inline, comm])
+machOpProps MO_Dbl_Div = (Just1 DoubleRep, [inline])
+machOpProps MO_Dbl_Pwr = (Just1 DoubleRep, [])
+
+machOpProps MO_Dbl_Sin = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Cos = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Tan = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Sinh = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Cosh = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Tanh = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Asin = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Acos = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Atan = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Log = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Exp = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Sqrt = (Just1 DoubleRep, [])
+machOpProps MO_Dbl_Neg = (Just1 DoubleRep, [inline])
+
+machOpProps MO_Flt_Add = (Just1 FloatRep, [inline, comm])
+machOpProps MO_Flt_Sub = (Just1 FloatRep, [inline])
+machOpProps MO_Flt_Mul = (Just1 FloatRep, [inline, comm])
+machOpProps MO_Flt_Div = (Just1 FloatRep, [inline])
+machOpProps MO_Flt_Pwr = (Just1 FloatRep, [])
+
+machOpProps MO_Flt_Eq = (Just1 IntRep, [inline, comp, comm])
+machOpProps MO_Flt_Ne = (Just1 IntRep, [inline, comp, comm])
+machOpProps MO_Flt_Ge = (Just1 IntRep, [inline, comp])
+machOpProps MO_Flt_Le = (Just1 IntRep, [inline, comp])
+machOpProps MO_Flt_Gt = (Just1 IntRep, [inline, comp])
+machOpProps MO_Flt_Lt = (Just1 IntRep, [inline, comp])
+
+machOpProps MO_Flt_Sin = (Just1 FloatRep, [])
+machOpProps MO_Flt_Cos = (Just1 FloatRep, [])
+machOpProps MO_Flt_Tan = (Just1 FloatRep, [])
+machOpProps MO_Flt_Sinh = (Just1 FloatRep, [])
+machOpProps MO_Flt_Cosh = (Just1 FloatRep, [])
+machOpProps MO_Flt_Tanh = (Just1 FloatRep, [])
+machOpProps MO_Flt_Asin = (Just1 FloatRep, [])
+machOpProps MO_Flt_Acos = (Just1 FloatRep, [])
+machOpProps MO_Flt_Atan = (Just1 FloatRep, [])
+machOpProps MO_Flt_Log = (Just1 FloatRep, [])
+machOpProps MO_Flt_Exp = (Just1 FloatRep, [])
+machOpProps MO_Flt_Sqrt = (Just1 FloatRep, [])
+machOpProps MO_Flt_Neg = (Just1 FloatRep, [inline])
+
+machOpProps MO_32U_to_NatS = (Just1 IntRep, [inline])
+machOpProps MO_NatS_to_32U = (Just1 WordRep, [inline])
+
+machOpProps MO_NatS_to_Dbl = (Just1 DoubleRep, [inline])
+machOpProps MO_Dbl_to_NatS = (Just1 IntRep, [inline])
+
+machOpProps MO_NatS_to_Flt = (Just1 FloatRep, [inline])
+machOpProps MO_Flt_to_NatS = (Just1 IntRep, [inline])
+
+machOpProps MO_NatS_to_NatU = (Just1 WordRep, [inline])
+machOpProps MO_NatU_to_NatS = (Just1 IntRep, [inline])
+
+machOpProps MO_NatS_to_NatP = (Just1 PtrRep, [inline])
+machOpProps MO_NatP_to_NatS = (Just1 IntRep, [inline])
+machOpProps MO_NatU_to_NatP = (Just1 PtrRep, [inline])
+machOpProps MO_NatP_to_NatU = (Just1 WordRep, [inline])
+
+machOpProps MO_Dbl_to_Flt = (Just1 FloatRep, [inline])
+machOpProps MO_Flt_to_Dbl = (Just1 DoubleRep, [inline])
+
+machOpProps MO_8S_to_NatS = (Just1 IntRep, [inline])
+machOpProps MO_16S_to_NatS = (Just1 IntRep, [inline])
+machOpProps MO_32S_to_NatS = (Just1 IntRep, [inline])
+
+machOpProps MO_8U_to_NatU = (Just1 WordRep, [inline])
+machOpProps MO_16U_to_NatU = (Just1 WordRep, [inline])
+machOpProps MO_32U_to_NatU = (Just1 WordRep, [inline])
+
+machOpProps (MO_ReadOSBI offset rep) = (Just1 rep, [inline])
+machOpProps (MO_WriteOSBI offset rep) = (Just0, [inline])
+
+
+
import IO ( Handle )
+import PrimRep
import AbsCSyn
import ClosureInfo
import AbsCUtils ( getAmodeRep, nonemptyAbsC,
mixedPtrLocn, mixedTypeLocn
)
-import Constants ( mIN_UPD_SIZE )
+import Constants ( mIN_UPD_SIZE, wORD_SIZE )
import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel,
import TyCon ( tyConDataCons )
import Name ( NamedThing(..) )
import DataCon ( dataConWrapId )
-import Maybes ( maybeToBool, catMaybes )
+import Maybes ( Maybe012(..), maybe012ToList, maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper )
+import MachOp ( MachOp(..) )
import ForeignCall ( ForeignCall(..) )
-import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
+import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, getPrimRepArrayElemSize )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
import Outputable
import GlaExts
import Util ( nOfThem, lengthExceeds, listLengthCmp )
+import Maybe ( isNothing )
import ST
-- primop macros do their own casting of result;
-- hence we can toss the provided cast...
+-- NEW CASES FOR EXPANDED PRIMOPS
+
+-- We have to deal with some of these specially
+pprAbsC (CMachOpStmt (Just1 res) (MO_ReadOSBI offw scaleRep)
+ [baseAmode, indexAmode] maybe_vols)
+ _
+ | isNothing maybe_vols
+ = hcat [ -- text " /* ReadOSBI */ ",
+ ppr_amode res, equals,
+ ppr_array_expression offw scaleRep baseAmode indexAmode,
+ semi ]
+ | otherwise
+ = panic "pprAbsC:MO_ReadOSBI -- out-of-line array indexing ?!?!"
+
+pprAbsC (CMachOpStmt Just0 (MO_WriteOSBI offw scaleRep)
+ [baseAmode, indexAmode, vAmode] maybe_vols)
+ _
+ | isNothing maybe_vols
+ = hcat [ -- text " /* WriteOSBI */ ",
+ ppr_array_expression offw scaleRep baseAmode indexAmode,
+ equals, pprAmode vAmode,
+ semi ]
+ | otherwise
+ = panic "pprAbsC:MO_WriteOSBI -- out-of-line array indexing ?!?!"
+
+pprAbsC (CMachOpStmt (Just2 res carry) mop [arg1,arg2] maybe_vols) _
+ | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC]
+ = hcat [ pprMachOp_for_C mop,
+ lparen,
+ ppr_amode res, comma, ppr_amode carry, comma,
+ pprAmode arg1, comma, pprAmode arg2,
+ rparen, semi ]
+
+-- The rest generically.
+
+pprAbsC stmt@(CMachOpStmt (Just1 res) mop [arg1,arg2] maybe_vols) _
+ = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr]
+ in
+ case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
+ saves $$
+ hcat (
+ [ppr_amode res, equals]
+ ++ (if prefix_fn
+ then [pprMachOp_for_C mop, parens (pprAmode arg1 <> comma <> pprAmode arg2)]
+ else [pprAmode arg1, pprMachOp_for_C mop, pprAmode arg2])
+ ++ [semi]
+ )
+ $$ restores
+ }
+
+pprAbsC stmt@(CMachOpStmt (Just1 res) mop [arg1] maybe_vols) _
+ = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) ->
+ saves $$
+ hcat [ppr_amode res, equals,
+ pprMachOp_for_C mop, parens (pprAmode arg1),
+ semi]
+ $$ restores
+ }
+
+pprAbsC stmt@(CSequential stuff) c
+ = vcat (map (flip pprAbsC c) stuff)
+
+-- end of NEW CASES FOR EXPANDED PRIMOPS
+
pprAbsC stmt@(CSRT lbl closures) c
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
pp_exts
\end{code}
\begin{code}
+-- Print a CMachOp in a way suitable for emitting via C.
+pprMachOp_for_C MO_Nat_Add = char '+'
+pprMachOp_for_C MO_Nat_Sub = char '-'
+pprMachOp_for_C MO_Nat_Eq = text "=="
+pprMachOp_for_C MO_Nat_Ne = text "!="
+
+pprMachOp_for_C MO_NatS_Ge = text ">="
+pprMachOp_for_C MO_NatS_Le = text "<="
+pprMachOp_for_C MO_NatS_Gt = text ">"
+pprMachOp_for_C MO_NatS_Lt = text "<"
+
+pprMachOp_for_C MO_NatU_Ge = text ">="
+pprMachOp_for_C MO_NatU_Le = text "<="
+pprMachOp_for_C MO_NatU_Gt = text ">"
+pprMachOp_for_C MO_NatU_Lt = text "<"
+
+pprMachOp_for_C MO_NatS_Mul = char '*'
+pprMachOp_for_C MO_NatS_Quot = char '/'
+pprMachOp_for_C MO_NatS_Rem = char '%'
+pprMachOp_for_C MO_NatS_Neg = char '-'
+
+pprMachOp_for_C MO_NatU_Mul = char '*'
+pprMachOp_for_C MO_NatU_Quot = char '/'
+pprMachOp_for_C MO_NatU_Rem = char '%'
+
+pprMachOp_for_C MO_NatS_AddC = text "addIntCzh"
+pprMachOp_for_C MO_NatS_SubC = text "subIntCzh"
+pprMachOp_for_C MO_NatS_MulC = text "mulIntCzh"
+
+pprMachOp_for_C MO_Nat_And = text "&"
+pprMachOp_for_C MO_Nat_Or = text "|"
+pprMachOp_for_C MO_Nat_Xor = text "^"
+pprMachOp_for_C MO_Nat_Not = text "~"
+pprMachOp_for_C MO_Nat_Shl = text "<<"
+pprMachOp_for_C MO_Nat_Shr = text ">>"
+pprMachOp_for_C MO_Nat_Sar = text ">>"
+
+pprMachOp_for_C MO_32U_Eq = text "=="
+pprMachOp_for_C MO_32U_Ne = text "!="
+pprMachOp_for_C MO_32U_Ge = text ">="
+pprMachOp_for_C MO_32U_Le = text "<="
+pprMachOp_for_C MO_32U_Gt = text ">"
+pprMachOp_for_C MO_32U_Lt = text "<"
+
+pprMachOp_for_C MO_Dbl_Eq = text "=="
+pprMachOp_for_C MO_Dbl_Ne = text "!="
+pprMachOp_for_C MO_Dbl_Ge = text ">="
+pprMachOp_for_C MO_Dbl_Le = text "<="
+pprMachOp_for_C MO_Dbl_Gt = text ">"
+pprMachOp_for_C MO_Dbl_Lt = text "<"
+
+pprMachOp_for_C MO_Dbl_Add = text "+"
+pprMachOp_for_C MO_Dbl_Sub = text "-"
+pprMachOp_for_C MO_Dbl_Mul = text "*"
+pprMachOp_for_C MO_Dbl_Div = text "/"
+pprMachOp_for_C MO_Dbl_Pwr = text "pow"
+
+pprMachOp_for_C MO_Dbl_Sin = text "sin"
+pprMachOp_for_C MO_Dbl_Cos = text "cos"
+pprMachOp_for_C MO_Dbl_Tan = text "tan"
+pprMachOp_for_C MO_Dbl_Sinh = text "sinh"
+pprMachOp_for_C MO_Dbl_Cosh = text "cosh"
+pprMachOp_for_C MO_Dbl_Tanh = text "tanh"
+pprMachOp_for_C MO_Dbl_Asin = text "asin"
+pprMachOp_for_C MO_Dbl_Acos = text "acos"
+pprMachOp_for_C MO_Dbl_Atan = text "atan"
+pprMachOp_for_C MO_Dbl_Log = text "log"
+pprMachOp_for_C MO_Dbl_Exp = text "exp"
+pprMachOp_for_C MO_Dbl_Sqrt = text "sqrt"
+pprMachOp_for_C MO_Dbl_Neg = text "-"
+
+pprMachOp_for_C MO_Flt_Add = text "+"
+pprMachOp_for_C MO_Flt_Sub = text "-"
+pprMachOp_for_C MO_Flt_Mul = text "*"
+pprMachOp_for_C MO_Flt_Div = text "/"
+pprMachOp_for_C MO_Flt_Pwr = text "pow"
+
+pprMachOp_for_C MO_Flt_Eq = text "=="
+pprMachOp_for_C MO_Flt_Ne = text "!="
+pprMachOp_for_C MO_Flt_Ge = text ">="
+pprMachOp_for_C MO_Flt_Le = text "<="
+pprMachOp_for_C MO_Flt_Gt = text ">"
+pprMachOp_for_C MO_Flt_Lt = text "<"
+
+pprMachOp_for_C MO_Flt_Sin = text "sin"
+pprMachOp_for_C MO_Flt_Cos = text "cos"
+pprMachOp_for_C MO_Flt_Tan = text "tan"
+pprMachOp_for_C MO_Flt_Sinh = text "sinh"
+pprMachOp_for_C MO_Flt_Cosh = text "cosh"
+pprMachOp_for_C MO_Flt_Tanh = text "tanh"
+pprMachOp_for_C MO_Flt_Asin = text "asin"
+pprMachOp_for_C MO_Flt_Acos = text "acos"
+pprMachOp_for_C MO_Flt_Atan = text "atan"
+pprMachOp_for_C MO_Flt_Log = text "log"
+pprMachOp_for_C MO_Flt_Exp = text "exp"
+pprMachOp_for_C MO_Flt_Sqrt = text "sqrt"
+pprMachOp_for_C MO_Flt_Neg = text "-"
+
+pprMachOp_for_C MO_32U_to_NatS = text "(StgInt)"
+pprMachOp_for_C MO_NatS_to_32U = text "(StgWord32)"
+
+pprMachOp_for_C MO_NatS_to_Dbl = text "(StgDouble)"
+pprMachOp_for_C MO_Dbl_to_NatS = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_Flt = text "(StgFloat)"
+pprMachOp_for_C MO_Flt_to_NatS = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_NatU = text "(StgWord)"
+pprMachOp_for_C MO_NatU_to_NatS = text "(StgInt)"
+
+pprMachOp_for_C MO_NatS_to_NatP = text "(void*)"
+pprMachOp_for_C MO_NatP_to_NatS = text "(StgInt)"
+pprMachOp_for_C MO_NatU_to_NatP = text "(void*)"
+pprMachOp_for_C MO_NatP_to_NatU = text "(StgWord)"
+
+pprMachOp_for_C MO_Dbl_to_Flt = text "(StgFloat)"
+pprMachOp_for_C MO_Flt_to_Dbl = text "(StgDouble)"
+
+pprMachOp_for_C MO_8S_to_NatS = text "(StgInt8)(StgInt)"
+pprMachOp_for_C MO_16S_to_NatS = text "(StgInt16)(StgInt)"
+pprMachOp_for_C MO_32S_to_NatS = text "(StgInt32)(StgInt)"
+
+pprMachOp_for_C MO_8U_to_NatU = text "(StgWord8)(StgWord)"
+pprMachOp_for_C MO_16U_to_NatU = text "(StgWord16)(StgWord)"
+pprMachOp_for_C MO_32U_to_NatU = text "(StgWord32)(StgWord)"
+
+pprMachOp_for_C (MO_ReadOSBI _ _) = panic "pprMachOp_for_C:MO_ReadOSBI"
+pprMachOp_for_C (MO_WriteOSBI _ _) = panic "pprMachOp_for_C:MO_WriteOSBI"
+
+
+-- Helper for printing array expressions.
+ppr_array_expression offw scaleRep baseAmode indexAmode
+ -- create:
+ -- * (scaleRep*) (
+ -- ((char*)baseAmode) + offw*bytes_per_word + indexAmode*bytes_per_scaleRep
+ -- )
+ = let offb = parens (int offw <> char '*' <> int wORD_SIZE)
+ indb = parens (parens (pprAmode indexAmode)
+ <> char '*' <> int (getPrimRepArrayElemSize scaleRep))
+ baseb = text "(char*)" <> parens (pprAmode baseAmode)
+ addr = parens baseb <+> char '+' <+> offb <+> char '+' <+> indb
+ in
+ char '*' <> parens (ppr scaleRep <> char '*') <> parens addr
+
+
ppLocalness lbl
= if (externallyVisibleCLabel lbl)
then empty
\end{code}
\begin{code}
+ppr_maybe_vol_regs :: Maybe [MagicId] -> (SDoc, SDoc)
+ppr_maybe_vol_regs Nothing
+ = (empty, empty)
+ppr_maybe_vol_regs (Just vrs)
+ = case ppr_vol_regs vrs of
+ (saves, restores)
+ -> (pp_basic_saves $$ saves,
+ pp_basic_restores $$ restores)
+
ppr_vol_regs :: [MagicId] -> (SDoc, SDoc)
ppr_vol_regs [] = (empty, empty)
-- ---------------------------------------------------------------------------
do_if_stmt discrim tag alt_code deflt c
- = case tag of
- -- This special case happens when testing the result of a comparison.
- -- We can just avoid some redundant clutter in the output.
- MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim)
- deflt alt_code
- (addrModeCosts discrim Rhs) c
- other -> let
- cond = hcat [ pprAmode discrim
- , ptext SLIT(" == ")
- , tcast
- , pprAmode (CLit tag)
- ]
- -- to be absolutely sure that none of the
- -- conversion rules hit, e.g.,
- --
- -- minInt is different to (int)minInt
- --
- -- in C (when minInt is a number not a constant
- -- expression which evaluates to it.)
- --
- tcast = case other of
- MachInt _ -> ptext SLIT("(I_)")
- _ -> empty
- in
- ppr_if_stmt cond
- alt_code deflt
- (addrModeCosts discrim Rhs) c
+ = let
+ cond = hcat [ pprAmode discrim
+ , ptext SLIT(" == ")
+ , tcast
+ , pprAmode (CLit tag)
+ ]
+ -- to be absolutely sure that none of the
+ -- conversion rules hit, e.g.,
+ --
+ -- minInt is different to (int)minInt
+ --
+ -- in C (when minInt is a number not a constant
+ -- expression which evaluates to it.)
+ --
+ tcast = case tag of
+ MachInt _ -> ptext SLIT("(I_)")
+ _ -> empty
+ in
+ ppr_if_stmt cond
+ alt_code deflt
+ (addrModeCosts discrim Rhs) c
ppr_if_stmt pp_pred then_part else_part discrim_costs c
= vcat [
amode has kind2.
\begin{code}
+ppr_amode (CMem rep addr)
+ = let txt_rep = pprPrimKind rep
+ in hcat [ char '*', parens (txt_rep <> char '*'), parens (ppr_amode addr) ]
+
ppr_amode (CVal reg_rel@(CIndex _ _ _) kind)
= case (pprRegRelative False{-no sign wanted-} reg_rel) of
(pp_reg, Nothing) -> panic "ppr_amode: CIndex"
cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN")
\end{code}
+\begin{code}
+\end{code}
+
%************************************************************************
%* *
\subsection[ppr-liveness-masks]{Liveness Masks}
where
info_lbl = infoTableLabelFromCI cl_info
+ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (maybe012ToList res ++ args)
ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args)
+
ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc
+ppr_decls_AbsC (CSequential abcs)
+ = mapTE ppr_decls_AbsC abcs `thenTE` \ t_and_e_s ->
+ returnTE (maybe_vcat t_and_e_s)
+
ppr_decls_AbsC (CCheck _ amodes code) =
ppr_decls_Amodes amodes `thenTE` \p1 ->
ppr_decls_AbsC code `thenTE` \p2 ->
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.54 2001/10/11 14:31:45 sewardj Exp $
+% $Id: CgCase.lhs,v 1.55 2001/12/05 17:35:13 sewardj Exp $
%
%********************************************************
%* *
tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
in
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
- absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
+ absC (COpStmt [tag_amode] op arg_amodes vol_regs)
+ `thenC`
-- NB: no liveness arg
returnFC tag_amode
} `thenFC` \ tag_amode ->
import List ( replicate )
import System ( ExitCode(..), exitWith )
-import IO ( hPutStr, hPutStrLn, stderr )
+import IO ( hPutStr, hPutStrLn, stderr, stdout )
\end{code}
\begin{code}
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
- | dopt flag dflags || verbosity dflags >= 4 = printDump (dump hdr doc)
- | otherwise = return ()
+ | dopt flag dflags || verbosity dflags >= 4
+ = if flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm]
+ then printForC stdout (dump hdr doc)
+ else printDump (dump hdr doc)
+ | otherwise
+ = return ()
dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
dumpIfSet_dyn_or dflags flags hdr doc
rET_SMALL, rET_BIG,
rET_VEC_SMALL, rET_VEC_BIG
)
-import Constants ( mIN_UPD_SIZE )
+import Constants ( mIN_UPD_SIZE, wORD_SIZE )
import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
mkClosureTblLabel, mkClosureLabel,
labelDynamic, mkSplitMarkerLabel )
staticClosureNeedsLink
)
import Literal ( Literal(..), word2IntLit )
-import Maybes ( maybeToBool )
+import Maybes ( Maybe012(..), maybeToBool )
import StgSyn ( StgOp(..) )
-import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
+import MachOp ( MachOp(..), resultRepsOfMachOp )
import PrimRep ( isFloatingRep, PrimRep(..) )
import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
livenessIsSmall, bitmapToIntegers )
import StixMacro ( macroCode, checkCode )
-import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' )
+import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' )
import Outputable ( pprPanic, ppr )
import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import Util ( naturalMergeSortLe )
import Name ( NamedThing(..) )
import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
import Outputable ( assertPanic )
+
+-- DEBUGGING ONLY
+--import IOExts ( trace )
+--import Outputable ( showSDoc )
+--import MachOp ( pprMachOp )
+
\end{code}
For each independent chunk of AbstractC code, we generate a list of
performed locally within the chunk.
\begin{code}
-genCodeAbstractC :: AbstractC -> UniqSM [StixTree]
+genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]
genCodeAbstractC absC
= gentopcode absC
a2stix' = amodeToStix'
volsaves = volatileSaves
volrestores = volatileRestores
- p2stix = primCode
macro_code = macroCode
-- real code follows... ---------
\end{code}
, StData DataPtrRep (map mk_StCLbl_for_SRT closures)
]
where
- mk_StCLbl_for_SRT :: CLabel -> StixTree
+ mk_StCLbl_for_SRT :: CLabel -> StixExpr
mk_StCLbl_for_SRT label
| labelDynamic label
= StIndex Int8Rep (StCLbl label) (StInt 1)
: StData IntRep [StInt 0]
: StSegment TextSegment
: StLabel lbl
- : StCondJump tmp_lbl (StPrim IntNeOp
+ : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
[StInd IntRep (StCLbl flag_lbl),
StInt 0])
- : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1)
+ : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
: code
[ StLabel tmp_lbl
- , StAssign PtrRep stgSp
- (StIndex PtrRep stgSp (StInt (-1)))
- , StJump NoDestInfo (StInd WordRep stgSp)
+ , StAssignReg PtrRep stgSp
+ (StIndex PtrRep (StReg stgSp) (StInt (-1)))
+ , StJump NoDestInfo (StInd WordRep (StReg stgSp))
])
gentopcode absC
gencode c2 `thenUs` \ b2 ->
returnUs (b1 . b2)
+ gencode (CSequential stuff)
+ = foo stuff
+ where
+ foo [] = returnUs id
+ foo (s:ss) = gencode s `thenUs` \ stix ->
+ foo ss `thenUs` \ stixes ->
+ returnUs (stix . stixes)
+
\end{code}
Initialising closure headers in the heap...a fairly complex ordeal if
lhs = a2stix reg_rel
lbl = infoTableLabelFromCI cl_info
in
- returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
+ returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
\end{code}
lhs' = a2stix lhs
rhs' = a2stix' rhs
in
- returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
+ returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
\end{code}
= returnUs (\xs -> StJump NoDestInfo dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
- dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
- StInt (toInteger (fixedItblSize+1))]
+ dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
+ StInt (toInteger (fixedItblSize+1))]
\end{code}
foreignCallCode (nonVoid results) fcall (nonVoid args)
gencode (COpStmt results (StgPrimOp op) args vols)
- -- ToDo (ADR?): use that liveness mask
- | primOpNeedsWrapper op
- = let
- saves = volsaves vols
- restores = volrestores vols
+ = panic "AbsCStixGen.gencode: un-translated PrimOp"
+
+ -- Translate out array indexing primops right here, so that
+ -- individual targets don't have to deal with them
+
+ gencode (CMachOpStmt (Just1 r1) (MO_ReadOSBI off_w rep) [base,index] vols)
+ = returnUs (\xs ->
+ mkStAssign
+ rep
+ (a2stix r1)
+ (StInd rep (StMachOp MO_Nat_Add
+ [StIndex rep (a2stix base) (a2stix index),
+ StInt (toInteger (off_w * wORD_SIZE))]))
+ : xs
+ )
+
+ gencode (CMachOpStmt Just0 (MO_WriteOSBI off_w rep) [base,index,val] vols)
+ = returnUs (\xs ->
+ StAssignMem
+ rep
+ (StMachOp MO_Nat_Add
+ [StIndex rep (a2stix base) (a2stix index),
+ StInt (toInteger (off_w * wORD_SIZE))])
+ (a2stix val)
+ : xs
+ )
+
+ -- Gruesome cases for multiple-result primops
+ gencode (CMachOpStmt (Just2 r1 r2) mop [arg1, arg2] vols)
+ | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC]
+ = getUniqueUs `thenUs` \ u1 ->
+ getUniqueUs `thenUs` \ u2 ->
+ let vr1 = StixVReg u1 IntRep
+ vr2 = StixVReg u2 IntRep
+ r1s = a2stix r1
+ r2s = a2stix r2
in
- p2stix (nonVoid results) op (nonVoid args)
- `thenUs` \ code ->
- returnUs (\xs -> saves ++ code (restores ++ xs))
+ returnUs (\xs ->
+ StAssignMachOp (Just2 vr1 vr2) mop [a2stix arg1, a2stix arg2]
+ : mkStAssign IntRep r1s (StReg (StixTemp vr1))
+ : mkStAssign IntRep r2s (StReg (StixTemp vr2))
+ : xs
+ )
+
+ -- Ordinary MachOps are passed through unchanged.
- | otherwise = p2stix (nonVoid results) op (nonVoid args)
+ gencode (CMachOpStmt (Just1 r1) mop args vols)
+ = let (Just1 rep) = resultRepsOfMachOp mop
+ in
+ returnUs (\xs ->
+ mkStAssign rep (a2stix r1)
+ (StMachOp mop (map a2stix args))
+ : xs
+ )
\end{code}
Now the dreaded conditional jump.
mkJumpTable am alts lowTag highTag dflt
= getUniqLabelNCG `thenUs` \ utlbl ->
mapUs genLabel alts `thenUs` \ branches ->
- let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
- cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
+ let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
+ cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
- offset = StPrim IntSubOp [am, StInt lowTag]
+ offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
dsts = DestInfo (dflt : map fst branches)
jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
| rangeOfOne = gencode alt
| otherwise
= let tag' = a2stix (CLit tag)
- cmpOp = if floating then DoubleNeOp else IntNeOp
- test = StPrim cmpOp [am, tag']
+ cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
+ test = StMachOp cmpOp [am, tag']
cjmp = StCondJump udlbl test
in
gencode alt `thenUs` \ alt_code ->
mkBinaryTree am floating alts choices lowTag highTag udlbl
= getUniqLabelNCG `thenUs` \ uhlbl ->
let tag' = a2stix (CLit splitTag)
- cmpOp = if floating then DoubleGeOp else IntGeOp
- test = StPrim cmpOp [am, tag']
+ cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
+ test = StMachOp cmpOp [am, tag']
cjmp = StCondJump uhlbl test
in
mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
getUniqLabelNCG `thenUs` \ utlbl ->
let discrim' = a2stix discrim
tag' = a2stix (CLit tag)
- cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
- test = StPrim cmpOp [discrim', tag']
+ cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
+ test = StMachOp cmpOp [discrim', tag']
cjmp = StCondJump utlbl test
dest = StLabel utlbl
join = StLabel ujlbl
gencode deflt `thenUs` \ dflt_code ->
returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
-mkJoin :: AbstractC -> CLabel -> AbstractC
+mkJoin :: AbstractC -> CLabel -> AbstractC
mkJoin code lbl
| mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
| otherwise = code
import AbsCStixGen ( genCodeAbstractC )
import AbsCSyn ( AbstractC )
-import AbsCUtils ( mkAbsCStmtList )
+import AbsCUtils ( mkAbsCStmtList, magicIdPrimRep )
import AsmRegAlloc ( runRegAllocate )
-import PrimOp ( commutableOp, PrimOp(..) )
+import MachOp ( MachOp(..), isCommutableMachOp, isComparisonMachOp )
import RegAllocInfo ( findReservedRegs )
-import Stix ( StixTree(..), StixReg(..),
- pprStixTrees, pprStixTree,
- stixCountTempUses, stixSubst,
+import Stix ( StixReg(..), StixStmt(..), StixExpr(..), StixVReg(..),
+ pprStixStmts, pprStixStmt,
+ stixStmt_CountTempUses, stixStmt_Subst,
+ liftStrings,
initNat, mapNat,
mkNatM_State,
uniqOfNatM_State, deltaOfNatM_State )
insn_sdoc = my_vcat insn_sdocs
stix_sdoc = vcat stix_sdocs
-# ifdef NCG_DEBUG
+# ifdef NCG_DEBUG */
my_trace m x = trace m x
- my_vcat sds = vcat (intersperse (char ' '
- $$ ptext SLIT("# ___ncg_debug_marker")
- $$ char ' ')
- sds)
+ my_vcat sds = Pretty.vcat (
+ intersperse (
+ Pretty.char ' '
+ Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker")
+ Pretty.$$ Pretty.char ' '
+ )
+ sds
+ )
# else
my_vcat sds = Pretty.vcat sds
my_trace m x = x
absCtoNat absC
= _scc_ "genCodeAbstractC" genCodeAbstractC absC `thenUs` \ stixRaw ->
_scc_ "genericOpt" genericOpt stixRaw `bind` \ stixOpt ->
- _scc_ "genMachCode" genMachCode stixOpt `thenUs` \ pre_regalloc ->
+ _scc_ "liftStrings" liftStrings stixOpt `thenUs` \ stixLifted ->
+ _scc_ "genMachCode" genMachCode stixLifted `thenUs` \ pre_regalloc ->
_scc_ "regAlloc" regAlloc pre_regalloc `bind` \ almost_final ->
_scc_ "x86fp_kludge" x86fp_kludge almost_final `bind` \ final_mach_code ->
_scc_ "vcat" Pretty.vcat (map pprInstr final_mach_code) `bind` \ final_sdoc ->
- _scc_ "pprStixTrees" pprStixTrees stixOpt `bind` \ stix_sdoc ->
+ _scc_ "pprStixTrees" pprStixStmts stixOpt `bind` \ stix_sdoc ->
returnUs (stix_sdoc, final_sdoc)
where
bind f x = x f
supply breaks abstraction. Is that bad?
\begin{code}
-genMachCode :: [StixTree] -> UniqSM InstrBlock
+genMachCode :: [StixStmt] -> UniqSM InstrBlock
genMachCode stmts initial_us
= let initial_st = mkNatM_State initial_us 0
address manipulations.
\begin{code}
-genericOpt :: [StixTree] -> [StixTree]
-genericOpt = map stixConFold . stixPeep
+genericOpt :: [StixStmt] -> [StixStmt]
+genericOpt = map stixStmt_ConFold . stixPeep
-stixPeep :: [StixTree] -> [StixTree]
+stixPeep :: [StixStmt] -> [StixStmt]
-- This transformation assumes that the temp assigned to in t1
-- is not assigned to in t2; for otherwise the target of the
-- code. As far as I can see, StixTemps are only ever assigned
-- to once. It would be nice to be sure!
-stixPeep ( t1@(StAssign pka (StReg (StixTemp u pk)) rhs)
+stixPeep ( t1@(StAssignReg pka (StixTemp (StixVReg u pk)) rhs)
: t2
: ts )
- | stixCountTempUses u t2 == 1
- && sum (map (stixCountTempUses u) ts) == 0
+ | stixStmt_CountTempUses u t2 == 1
+ && sum (map (stixStmt_CountTempUses u) ts) == 0
=
# ifdef NCG_DEBUG
- trace ("nativeGen: inlining " ++ showSDoc (pprStixTree rhs))
+ trace ("nativeGen: inlining " ++ showSDoc (pprStixExpr rhs))
# endif
- (stixPeep (stixSubst u rhs t2 : ts))
+ (stixPeep (stixStmt_Subst u rhs t2 : ts))
stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts)
stixPeep [t1] = [t1]
stixPeep [] = []
-
--- disable stix inlining until we figure out how to fix the
--- latent bugs in the register allocator which are exposed by
--- the inliner.
---stixPeep = id
\end{code}
For most nodes, just optimize the children.
\begin{code}
-stixConFold :: StixTree -> StixTree
-
-stixConFold (StInd pk addr) = StInd pk (stixConFold addr)
-
-stixConFold (StAssign pk dst src)
- = StAssign pk (stixConFold dst) (stixConFold src)
-
-stixConFold (StJump dsts addr) = StJump dsts (stixConFold addr)
-
-stixConFold (StCondJump addr test)
- = StCondJump addr (stixConFold test)
-
-stixConFold (StCall fn cconv pk args)
- = StCall fn cconv pk (map stixConFold args)
-\end{code}
-
-Fold indices together when the types match:
-\begin{code}
-stixConFold (StIndex pk (StIndex pk' base off) off')
- | pk == pk'
- = StIndex pk (stixConFold base)
- (stixConFold (StPrim IntAddOp [off, off']))
-
-stixConFold (StIndex pk base off)
- = StIndex pk (stixConFold base) (stixConFold off)
-\end{code}
-
-For PrimOps, we first optimize the children, and then we try our hand
-at some constant-folding.
-
-\begin{code}
-stixConFold (StPrim op args) = stixPrimFold op (map stixConFold args)
-\end{code}
-
-Replace register leaves with appropriate StixTrees for the given
-target.
-
-\begin{code}
-stixConFold leaf@(StReg (StixMagicId id))
- = case (stgReg id) of
- Always tree -> stixConFold tree
- Save _ -> leaf
-
-stixConFold other = other
+stixExpr_ConFold :: StixExpr -> StixExpr
+stixStmt_ConFold :: StixStmt -> StixStmt
+
+stixStmt_ConFold stmt
+ = case stmt of
+ StAssignReg pk reg@(StixTemp _) src
+ -> StAssignReg pk reg (stixExpr_ConFold src)
+ StAssignReg pk reg@(StixMagicId mid) src
+ -- Replace register leaves with appropriate StixTrees for
+ -- the given target.
+ -> case get_MagicId_reg_or_addr mid of
+ Left realreg
+ -> StAssignReg pk reg (stixExpr_ConFold src)
+ Right baseRegAddr
+ -> stixStmt_ConFold
+ (StAssignMem pk baseRegAddr src)
+ StAssignMem pk addr src
+ -> StAssignMem pk (stixExpr_ConFold addr) (stixExpr_ConFold src)
+ StAssignMachOp lhss mop args
+ -> StAssignMachOp lhss mop (map stixExpr_ConFold args)
+ StVoidable expr
+ -> StVoidable (stixExpr_ConFold expr)
+ StJump dsts addr
+ -> StJump dsts (stixExpr_ConFold addr)
+ StCondJump addr test
+ -> StCondJump addr (stixExpr_ConFold test)
+ StData pk datas
+ -> StData pk (map stixExpr_ConFold datas)
+ other
+ -> other
+
+
+stixExpr_ConFold expr
+ = case expr of
+ StInd pk addr
+ -> StInd pk (stixExpr_ConFold addr)
+ StCall fn cconv pk args
+ -> StCall fn cconv pk (map stixExpr_ConFold args)
+ StIndex pk (StIndex pk' base off) off'
+ -- Fold indices together when the types match:
+ | pk == pk'
+ -> StIndex pk (stixExpr_ConFold base)
+ (stixExpr_ConFold (StMachOp MO_Nat_Add [off, off']))
+ StIndex pk base off
+ -> StIndex pk (stixExpr_ConFold base) (stixExpr_ConFold off)
+
+ StMachOp mop args
+ -- For PrimOps, we first optimize the children, and then we try
+ -- our hand at some constant-folding.
+ -> stixMachOpFold mop (map stixExpr_ConFold args)
+ StReg (StixMagicId mid)
+ -- Replace register leaves with appropriate StixTrees for
+ -- the given target.
+ -> case get_MagicId_reg_or_addr mid of
+ Left realreg -> expr
+ Right baseRegAddr
+ -> stixExpr_ConFold (StInd (magicIdPrimRep mid) baseRegAddr)
+ other
+ -> other
\end{code}
Now, try to constant-fold the PrimOps. The arguments have already
been optimized and folded.
\begin{code}
-stixPrimFold
- :: PrimOp -- The operation from an StPrim
- -> [StixTree] -- The optimized arguments
- -> StixTree
-
-stixPrimFold op arg@[StInt x]
- = case op of
- IntNegOp -> StInt (-x)
- _ -> StPrim op arg
-
-stixPrimFold op args@[StInt x, StInt y]
- = case op of
- CharGtOp -> StInt (if x > y then 1 else 0)
- CharGeOp -> StInt (if x >= y then 1 else 0)
- CharEqOp -> StInt (if x == y then 1 else 0)
- CharNeOp -> StInt (if x /= y then 1 else 0)
- CharLtOp -> StInt (if x < y then 1 else 0)
- CharLeOp -> StInt (if x <= y then 1 else 0)
- IntAddOp -> StInt (x + y)
- IntSubOp -> StInt (x - y)
- IntMulOp -> StInt (x * y)
- IntQuotOp -> StInt (x `quot` y)
- IntRemOp -> StInt (x `rem` y)
- IntGtOp -> StInt (if x > y then 1 else 0)
- IntGeOp -> StInt (if x >= y then 1 else 0)
- IntEqOp -> StInt (if x == y then 1 else 0)
- IntNeOp -> StInt (if x /= y then 1 else 0)
- IntLtOp -> StInt (if x < y then 1 else 0)
- IntLeOp -> StInt (if x <= y then 1 else 0)
- -- ToDo: WordQuotOp, WordRemOp.
- _ -> StPrim op args
+stixMachOpFold
+ :: MachOp -- The operation from an StMachOp
+ -> [StixExpr] -- The optimized arguments
+ -> StixExpr
+
+stixMachOpFold mop arg@[StInt x]
+ = case mop of
+ MO_NatS_Neg -> StInt (-x)
+ other -> StMachOp mop arg
+
+stixMachOpFold mop args@[StInt x, StInt y]
+ = case mop of
+ MO_32U_Gt -> StInt (if x > y then 1 else 0)
+ MO_32U_Ge -> StInt (if x >= y then 1 else 0)
+ MO_32U_Eq -> StInt (if x == y then 1 else 0)
+ MO_32U_Ne -> StInt (if x /= y then 1 else 0)
+ MO_32U_Lt -> StInt (if x < y then 1 else 0)
+ MO_32U_Le -> StInt (if x <= y then 1 else 0)
+ MO_Nat_Add -> StInt (x + y)
+ MO_Nat_Sub -> StInt (x - y)
+ MO_NatS_Mul -> StInt (x * y)
+ MO_NatS_Quot | y /= 0 -> StInt (x `quot` y)
+ MO_NatS_Rem | y /= 0 -> StInt (x `rem` y)
+ MO_NatS_Gt -> StInt (if x > y then 1 else 0)
+ MO_NatS_Ge -> StInt (if x >= y then 1 else 0)
+ MO_Nat_Eq -> StInt (if x == y then 1 else 0)
+ MO_Nat_Ne -> StInt (if x /= y then 1 else 0)
+ MO_NatS_Lt -> StInt (if x < y then 1 else 0)
+ MO_NatS_Le -> StInt (if x <= y then 1 else 0)
+ other -> StMachOp mop args
\end{code}
When possible, shift the constants to the right-hand side, so that we
possible.
\begin{code}
-stixPrimFold op [x@(StInt _), y] | commutableOp op = stixPrimFold op [y, x]
+stixMachOpFold op [x@(StInt _), y] | isCommutableMachOp op
+ = stixMachOpFold op [y, x]
\end{code}
We can often do something with constants of 0 and 1 ...
\begin{code}
-stixPrimFold op args@[x, y@(StInt 0)]
- = case op of
- IntAddOp -> x
- IntSubOp -> x
- IntMulOp -> y
- AndOp -> y
- OrOp -> x
- XorOp -> x
- SllOp -> x
- SrlOp -> x
- ISllOp -> x
- ISraOp -> x
- ISrlOp -> x
- IntNeOp | is_comparison -> x
- _ -> StPrim op args
+stixMachOpFold mop args@[x, y@(StInt 0)]
+ = case mop of
+ MO_Nat_Add -> x
+ MO_Nat_Sub -> x
+ MO_NatS_Mul -> y
+ MO_NatU_Mul -> y
+ MO_Nat_And -> y
+ MO_Nat_Or -> x
+ MO_Nat_Xor -> x
+ MO_Nat_Shl -> x
+ MO_Nat_Shr -> x
+ MO_Nat_Sar -> x
+ MO_Nat_Ne | x_is_comparison -> x
+ other -> StMachOp mop args
where
- is_comparison
+ x_is_comparison
= case x of
- StPrim opp [_, _] -> opp `elem` comparison_ops
- _ -> False
-
-stixPrimFold op args@[x, y@(StInt 1)]
- = case op of
- IntMulOp -> x
- IntQuotOp -> x
- IntRemOp -> StInt 0
- _ -> StPrim op args
+ StMachOp mopp [_, _] -> isComparisonMachOp mopp
+ _ -> False
+
+stixMachOpFold mop args@[x, y@(StInt 1)]
+ = case mop of
+ MO_NatS_Mul -> x
+ MO_NatU_Mul -> x
+ MO_NatS_Quot -> x
+ MO_NatU_Quot -> x
+ MO_NatS_Rem -> StInt 0
+ MO_NatU_Rem -> StInt 0
+ other -> StMachOp mop args
\end{code}
Now look for multiplication/division by powers of 2 (integers).
\begin{code}
-stixPrimFold op args@[x, y@(StInt n)]
- = case op of
- IntMulOp -> case exactLog2 n of
- Nothing -> StPrim op args
- Just p -> StPrim ISllOp [x, StInt p]
- IntQuotOp -> case exactLog2 n of
- Nothing -> StPrim op args
- Just p -> StPrim ISrlOp [x, StInt p]
- _ -> StPrim op args
+stixMachOpFold mop args@[x, y@(StInt n)]
+ = case mop of
+ MO_NatS_Mul
+ -> case exactLog2 n of
+ Nothing -> unchanged
+ Just p -> StMachOp MO_Nat_Shl [x, StInt p]
+ MO_NatS_Quot
+ -> case exactLog2 n of
+ Nothing -> unchanged
+ Just p -> StMachOp MO_Nat_Shr [x, StInt p]
+ other
+ -> unchanged
+ where
+ unchanged = StMachOp mop args
\end{code}
Anything else is just too hard.
\begin{code}
-stixPrimFold op args = StPrim op args
-\end{code}
-
-\begin{code}
-comparison_ops
- = [ CharGtOp , CharGeOp , CharEqOp , CharNeOp , CharLtOp , CharLeOp,
- IntGtOp , IntGeOp , IntEqOp , IntNeOp , IntLtOp , IntLeOp,
- WordGtOp , WordGeOp , WordEqOp , WordNeOp , WordLtOp , WordLeOp,
- AddrGtOp , AddrGeOp , AddrEqOp , AddrNeOp , AddrLtOp , AddrLeOp,
- FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp,
- DoubleGtOp, DoubleGeOp, DoubleEqOp, DoubleNeOp, DoubleLtOp, DoubleLeOp
- ]
+stixMachOpFold mop args = StMachOp mop args
\end{code}
import MachRegs
import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
snocOL, consOL, concatOL )
+import MachOp ( MachOp(..), pprMachOp )
import AbsCUtils ( magicIdPrimRep )
+import PprAbsC ( pprMagicId )
import ForeignCall ( CCallConv(..) )
import CLabel ( CLabel, labelDynamic )
#if sparc_TARGET_ARCH || alpha_TARGET_ARCH
import CLabel ( isAsmTemp )
#endif
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, Maybe012(..) )
import PrimRep ( isFloatingRep, PrimRep(..) )
-import PrimOp ( PrimOp(..) )
-import Stix ( getNatLabelNCG, StixTree(..),
- StixReg(..), CodeSegment(..),
+import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
+ StixReg(..), StixVReg(..), CodeSegment(..),
DestInfo, hasDestInfo,
- pprStixTree,
+ pprStixExpr,
+ liftStrings,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
getDeltaNat, setDeltaNat,
ncgPrimopMoan
)
import Pretty
-import Outputable ( panic, pprPanic )
+import Outputable ( panic, pprPanic, showSDoc )
import qualified Outputable
import CmdLineOpts ( opt_Static )
+-- DEBUGGING ONLY
+import IOExts ( trace )
+import Stix ( pprStixStmt )
+
infixr 3 `bind`
\end{code}
Code extractor for an entire stix tree---stix statement level.
\begin{code}
-stmtsToInstrs :: [StixTree] -> NatM InstrBlock
+stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
stmtsToInstrs stmts
- = liftStrings stmts [] [] `thenNat` \ lifted ->
- mapNat stmtToInstrs lifted `thenNat` \ instrss ->
+ = mapNat stmtToInstrs stmts `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 :: StixStmt -> NatM InstrBlock
stmtToInstrs stmt = case stmt of
StComment s -> returnNat (unitOL (COMMENT s))
StSegment seg -> returnNat (unitOL (SEGMENT seg))
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)
+ -- A call returning void, ie one done for its side-effects. Note
+ -- that this is the only StVoidable we handle.
+ StVoidable (StCall fn cconv VoidRep args)
+ -> genCCall fn cconv VoidRep (map derefDLL args)
- StAssign pk dst src
- | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
- | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
+ StAssignMem pk addr src
+ | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
+ | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
+ StAssignReg pk reg src
+ | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
+ | otherwise -> assignReg_IntCode pk reg (derefDLL src)
+ StAssignMachOp lhss mop rhss
+ -> assignMachOp lhss mop rhss
StFallThrough lbl
-- When falling through on the Alpha, we still have to load pv
returnNat (DATA (primRepToSize kind) imms
`consOL` concatOL codes)
where
- getData :: StixTree -> NatM (InstrBlock, Imm)
+ getData :: StixExpr -> NatM (InstrBlock, Imm)
getData (StInt i) = returnNat (nilOL, ImmInteger i)
getData (StDouble d) = returnNat (nilOL, ImmDouble d)
getData (StFloat d) = returnNat (nilOL, ImmFloat d)
ImmIndex lbl (fromInteger off * sizeOf rep))
-- Top-level lifted-out string. The segment will already have been set
- -- (see liftStrings above).
- StString str
+ -- (see Stix.liftStrings).
+ StDataString str
-> returnNat (unitOL (ASCII True (_UNPK_ str)))
#ifdef DEBUG
-- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
-- not all such CLabel occurrences need this dereferencing -- SRTs don't
-- for one.
-derefDLL :: StixTree -> StixTree
+derefDLL :: StixExpr -> StixExpr
derefDLL tree
| opt_Static -- short out the entire deal if not doing DLLs
= tree
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)
+ StMachOp mop args -> StMachOp mop (map qq args)
StInd pk addr -> StInd pk (qq addr)
StCall who cc pk args -> StCall who cc pk (map qq args)
StInt _ -> t
StDouble _ -> t
StString _ -> t
StReg _ -> t
- StScratchWord _ -> t
_ -> pprPanic "derefDLL: unhandled case"
- (pprStixTree t)
+ (pprStixExpr t)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-mangleIndexTree :: StixTree -> StixTree
+mangleIndexTree :: StixExpr -> StixExpr
mangleIndexTree (StIndex pk base (StInt i))
- = StPrim IntAddOp [base, off]
+ = StMachOp MO_Nat_Add [base, off]
where
off = StInt (i * toInteger (sizeOf pk))
mangleIndexTree (StIndex pk base off)
- = StPrim IntAddOp [
+ = StMachOp MO_Nat_Add [
base,
let s = shift pk
- in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
- ]
+ in if s == 0 then off else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
+ ]
where
shift :: PrimRep -> Int
shift rep = case sizeOf rep of
\end{code}
\begin{code}
-maybeImm :: StixTree -> Maybe Imm
+maybeImm :: StixExpr -> Maybe Imm
maybeImm (StCLbl l)
= Just (ImmCLbl l)
registerRep (Fixed pk _ _) = pk
registerRep (Any pk _) = pk
+swizzleRegisterRep :: Register -> PrimRep -> Register
+swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
+swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
+
{-# INLINE registerCode #-}
{-# INLINE registerCodeF #-}
{-# INLINE registerName #-}
Generate code to get a subtree into a @Register@:
\begin{code}
-getRegister :: StixTree -> NatM Register
-getRegister (StReg (StixMagicId stgreg))
- = case (magicIdRegMaybe stgreg) of
- Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
- -- cannae be Nothing
+getRegisterReg :: StixReg -> NatM Register
-getRegister (StReg (StixTemp u pk))
+getRegisterReg (StixMagicId mid)
+ = case get_MagicId_reg_or_addr mid of
+ Left (RealReg rrno)
+ -> let pk = magicIdPrimRep mid
+ in returnNat (Fixed pk (RealReg rrno) nilOL)
+ Right baseRegAddr
+ -- By this stage, the only MagicIds remaining should be the
+ -- ones which map to a real machine register on this platform. Hence ...
+ -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
+
+getRegisterReg (StixTemp (StixVReg u pk))
= returnNat (Fixed pk (mkVReg u pk) nilOL)
-getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
+-------------
+
+getRegister :: StixExpr -> NatM Register
+
+getRegister (StReg reg)
+ = getRegisterReg reg
+
+getRegister tree@(StIndex _ _ _)
+ = getRegister (mangleIndexTree tree)
getRegister (StCall fn cconv kind args)
= genCCall fn cconv kind args `thenNat` \ call ->
in
returnNat (Any DoubleRep code)
--- Calculate the offset for (i+1) words above the _initial_
--- %esp value by first determining the current offset of it.
-getRegister (StScratchWord i)
- | i >= 0 && i < 6
- = getDeltaNat `thenNat` \ current_stack_offset ->
- let j = i+1 - (current_stack_offset `div` 4)
- code dst
- = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst))
- in
- returnNat (Any PtrRep code)
-getRegister (StPrim primop [x]) -- unary PrimOps
- = case primop of
- IntNegOp -> trivialUCode (NEGI L) x
- NotOp -> trivialUCode (NOT L) x
+getRegister (StMachOp mop [x]) -- unary MachOps
+ = case mop of
+ MO_NatS_Neg -> trivialUCode (NEGI L) x
+ MO_Nat_Not -> trivialUCode (NOT L) x
- FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
- DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
+ MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
+ MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
- FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
- DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
+ MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
+ MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
- FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
- DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
+ MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
+ MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
- FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
- DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
+ MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
+ MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
- FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
- DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
+ MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
+ MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
- Double2FloatOp -> trivialUFCode FloatRep GDTOF x
- Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
+ MO_Flt_to_NatS -> coerceFP2Int x
+ MO_NatS_to_Flt -> coerceInt2FP FloatRep x
+ MO_Dbl_to_NatS -> coerceFP2Int x
+ MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
+ -- Conversions which are a nop on x86
+ MO_NatS_to_32U -> conversionNop WordRep x
+ MO_32U_to_NatS -> conversionNop IntRep x
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP FloatRep x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP DoubleRep x
+ MO_NatU_to_NatS -> conversionNop IntRep x
+ MO_NatS_to_NatU -> conversionNop WordRep x
+ MO_NatP_to_NatU -> conversionNop WordRep x
+ MO_NatU_to_NatP -> conversionNop PtrRep x
+ MO_NatS_to_NatP -> conversionNop PtrRep x
+ MO_NatP_to_NatS -> conversionNop IntRep x
- other_op ->
- getRegister (StCall fn CCallConv DoubleRep [x])
- where
- (is_float_op, fn)
- = case primop of
- FloatExpOp -> (True, SLIT("exp"))
- FloatLogOp -> (True, SLIT("log"))
+ MO_Dbl_to_Flt -> conversionNop FloatRep x
+ MO_Flt_to_Dbl -> conversionNop DoubleRep x
- FloatAsinOp -> (True, SLIT("asin"))
- FloatAcosOp -> (True, SLIT("acos"))
- FloatAtanOp -> (True, SLIT("atan"))
+ MO_8U_to_NatU -> integerExtend False 24 x
+ MO_8S_to_NatS -> integerExtend True 24 x
+ MO_16U_to_NatU -> integerExtend False 16 x
+ MO_16S_to_NatS -> integerExtend True 16 x
- FloatSinhOp -> (True, SLIT("sinh"))
- FloatCoshOp -> (True, SLIT("cosh"))
- FloatTanhOp -> (True, SLIT("tanh"))
-
- DoubleExpOp -> (False, SLIT("exp"))
- DoubleLogOp -> (False, SLIT("log"))
-
- DoubleAsinOp -> (False, SLIT("asin"))
- DoubleAcosOp -> (False, SLIT("acos"))
- DoubleAtanOp -> (False, SLIT("atan"))
-
- DoubleSinhOp -> (False, SLIT("sinh"))
- DoubleCoshOp -> (False, SLIT("cosh"))
- DoubleTanhOp -> (False, SLIT("tanh"))
-
- other
- -> ncgPrimopMoan "getRegister(x86,unary primop)"
- (pprStixTree (StPrim primop [x]))
-
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
- = case primop of
- CharGtOp -> condIntReg GTT x y
- CharGeOp -> condIntReg GE x y
- CharEqOp -> condIntReg EQQ x y
- CharNeOp -> condIntReg NE x y
- CharLtOp -> condIntReg LTT x y
- CharLeOp -> condIntReg LE x y
-
- IntGtOp -> condIntReg GTT x y
- IntGeOp -> condIntReg GE x y
- IntEqOp -> condIntReg EQQ x y
- IntNeOp -> condIntReg NE x y
- IntLtOp -> condIntReg LTT x y
- IntLeOp -> condIntReg LE x y
-
- WordGtOp -> condIntReg GU x y
- WordGeOp -> condIntReg GEU x y
- WordEqOp -> condIntReg EQQ x y
- WordNeOp -> condIntReg NE x y
- WordLtOp -> condIntReg LU x y
- WordLeOp -> condIntReg LEU x y
-
- AddrGtOp -> condIntReg GU x y
- AddrGeOp -> condIntReg GEU x y
- AddrEqOp -> condIntReg EQQ x y
- AddrNeOp -> condIntReg NE x y
- AddrLtOp -> condIntReg LU x y
- AddrLeOp -> condIntReg LEU x y
-
- FloatGtOp -> condFltReg GTT x y
- FloatGeOp -> condFltReg GE x y
- FloatEqOp -> condFltReg EQQ x y
- FloatNeOp -> condFltReg NE x y
- FloatLtOp -> condFltReg LTT x y
- FloatLeOp -> condFltReg LE x y
-
- DoubleGtOp -> condFltReg GTT x y
- DoubleGeOp -> condFltReg GE x y
- DoubleEqOp -> condFltReg EQQ x y
- DoubleNeOp -> condFltReg NE x y
- DoubleLtOp -> condFltReg LTT x y
- DoubleLeOp -> condFltReg LE 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
- FloatDivOp -> trivialFCode FloatRep GDIV x y
-
- DoubleAddOp -> trivialFCode DoubleRep GADD x y
- DoubleSubOp -> trivialFCode DoubleRep GSUB 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
+ other_op
+ -> getRegister (
+ (if is_float_op then demote else id)
+ (StCall fn CCallConv DoubleRep
+ [(if is_float_op then promote else id) x])
+ )
+ where
+ integerExtend signed nBits x
+ = getRegister (
+ StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
+ [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]]
+ )
+
+ conversionNop new_rep expr
+ = getRegister expr `thenNat` \ e_code ->
+ returnNat (swizzleRegisterRep e_code new_rep)
+
+ promote x = StMachOp MO_Flt_to_Dbl [x]
+ demote x = StMachOp MO_Dbl_to_Flt [x]
+ (is_float_op, fn)
+ = case mop of
+ MO_Flt_Exp -> (True, SLIT("exp"))
+ MO_Flt_Log -> (True, SLIT("log"))
+
+ MO_Flt_Asin -> (True, SLIT("asin"))
+ MO_Flt_Acos -> (True, SLIT("acos"))
+ MO_Flt_Atan -> (True, SLIT("atan"))
+
+ MO_Flt_Sinh -> (True, SLIT("sinh"))
+ MO_Flt_Cosh -> (True, SLIT("cosh"))
+ MO_Flt_Tanh -> (True, SLIT("tanh"))
+
+ MO_Dbl_Exp -> (False, SLIT("exp"))
+ MO_Dbl_Log -> (False, SLIT("log"))
+
+ MO_Dbl_Asin -> (False, SLIT("asin"))
+ MO_Dbl_Acos -> (False, SLIT("acos"))
+ MO_Dbl_Atan -> (False, SLIT("atan"))
+
+ MO_Dbl_Sinh -> (False, SLIT("sinh"))
+ MO_Dbl_Cosh -> (False, SLIT("cosh"))
+ MO_Dbl_Tanh -> (False, SLIT("tanh"))
+
+ other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
+ (pprMachOp mop)
+
+
+getRegister (StMachOp mop [x, y]) -- dyadic MachOps
+ = case mop of
+ MO_32U_Gt -> condIntReg GTT x y
+ MO_32U_Ge -> condIntReg GE x y
+ MO_32U_Eq -> condIntReg EQQ x y
+ MO_32U_Ne -> condIntReg NE x y
+ MO_32U_Lt -> condIntReg LTT x y
+ MO_32U_Le -> condIntReg LE x y
+
+ MO_Nat_Eq -> condIntReg EQQ x y
+ MO_Nat_Ne -> condIntReg NE x y
+
+ MO_NatS_Gt -> condIntReg GTT x y
+ MO_NatS_Ge -> condIntReg GE x y
+ MO_NatS_Lt -> condIntReg LTT x y
+ MO_NatS_Le -> condIntReg LE x y
+
+ MO_NatU_Gt -> condIntReg GU x y
+ MO_NatU_Ge -> condIntReg GEU x y
+ MO_NatU_Lt -> condIntReg LU x y
+ MO_NatU_Le -> condIntReg LEU x y
+
+ MO_Flt_Gt -> condFltReg GTT x y
+ MO_Flt_Ge -> condFltReg GE x y
+ MO_Flt_Eq -> condFltReg EQQ x y
+ MO_Flt_Ne -> condFltReg NE x y
+ MO_Flt_Lt -> condFltReg LTT x y
+ MO_Flt_Le -> condFltReg LE x y
+
+ MO_Dbl_Gt -> condFltReg GTT x y
+ MO_Dbl_Ge -> condFltReg GE x y
+ MO_Dbl_Eq -> condFltReg EQQ x y
+ MO_Dbl_Ne -> condFltReg NE x y
+ MO_Dbl_Lt -> condFltReg LTT x y
+ MO_Dbl_Le -> condFltReg LE x y
+
+ MO_Nat_Add -> add_code L x y
+ MO_Nat_Sub -> sub_code L x y
+ MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
+ MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
+ MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
+ MO_NatU_Rem -> trivialCode (REM L) Nothing x y
+ MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
+ MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
+
+ MO_Flt_Add -> trivialFCode FloatRep GADD x y
+ MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
+ MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
+ MO_Flt_Div -> trivialFCode FloatRep GDIV x y
+
+ MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
+ MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
+ MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
+ MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
+
+ MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
+ MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
+ MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
{- Shift ops on x86s have constraints on their source, it
either has to be Imm, CL or 1
=> trivialCode's is not restrictive enough (sigh.)
- -}
-
- SllOp -> shift_code (SHL L) x y {-False-}
- SrlOp -> shift_code (SHR L) x y {-False-}
- ISllOp -> shift_code (SHL L) x y {-False-}
- ISraOp -> shift_code (SAR L) x y {-False-}
- ISrlOp -> shift_code (SHR L) x y {-False-}
+ -}
+ MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
+ MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
+ MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
- FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
+ MO_Flt_Pwr -> getRegister (demote
+ (StCall SLIT("pow") CCallConv DoubleRep
[promote x, promote y])
- where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
+ )
+ MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
[x, y])
- other
- -> ncgPrimopMoan "getRegister(x86,dyadic primop)"
- (pprStixTree (StPrim primop [x, y]))
+ other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
where
+ promote x = StMachOp MO_Flt_to_Dbl [x]
+ demote x = StMachOp MO_Dbl_to_Flt [x]
--------------------
shift_code :: (Imm -> Operand -> Instr)
- -> StixTree
- -> StixTree
+ -> StixExpr
+ -> StixExpr
-> NatM Register
{- Case1: shift length as immediate -}
returnNat (Any IntRep code__2)
--------------------
- add_code :: Size -> StixTree -> StixTree -> NatM Register
+ add_code :: Size -> StixExpr -> StixExpr -> NatM Register
add_code sz x (StInt y)
= getRegister x `thenNat` \ register ->
add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
--------------------
- sub_code :: Size -> StixTree -> StixTree -> NatM Register
+ sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
sub_code sz x (StInt y)
= getRegister x `thenNat` \ register ->
sub_code sz x y = trivialCode (SUB sz) Nothing x y
-
getRegister (StInd pk mem)
= getAmode mem `thenNat` \ amode ->
let
in
returnNat (Any PtrRep code)
| otherwise
- = ncgPrimopMoan "getRegister(x86)" (pprStixTree leaf)
+ = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
+
+assignMachOp :: Maybe012 StixVReg -> MachOp -> [StixExpr]
+ -> NatM InstrBlock
+
+assignMachOp (Just2 sv_rr sv_cc) mop [aa,bb]
+ | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC]
+ = getRegister aa `thenNat` \ registeraa ->
+ getRegister bb `thenNat` \ registerbb ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
+ getNewRegNCG IntRep `thenNat` \ tmpaa ->
+ getNewRegNCG IntRep `thenNat` \ tmpbb ->
+ let stixVReg_to_VReg (StixVReg u rep) = mkVReg u rep
+ rr = stixVReg_to_VReg sv_rr
+ cc = stixVReg_to_VReg sv_cc
+ codeaa = registerCode registeraa tmpaa
+ srcaa = registerName registeraa tmpaa
+ codebb = registerCode registerbb tmpbb
+ srcbb = registerName registerbb tmpbb
+
+ insn = case mop of MO_NatS_AddC -> ADD; MO_NatS_SubC -> SUB
+ MO_NatS_MulC -> IMUL
+ cond = if mop == MO_NatS_MulC then OFLO else CARRY
+ str = showSDoc (pprMachOp mop)
+
+ code = toOL [
+ COMMENT (_PK_ ("begin " ++ str)),
+ MOV L (OpReg srcbb) (OpReg tmp),
+ insn L (OpReg srcaa) (OpReg tmp),
+ MOV L (OpReg tmp) (OpReg rr),
+ MOV L (OpImm (ImmInt 0)) (OpReg eax),
+ SETCC cond (OpReg eax),
+ MOV L (OpReg eax) (OpReg cc),
+ COMMENT (_PK_ ("end " ++ str))
+ ]
+ in
+ returnNat (codeaa `appOL` codebb `appOL` code)
+
+
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
... (tmp) ...
\begin{code}
-getAmode :: StixTree -> NatM Amode
+getAmode :: StixExpr -> NatM Amode
getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-getAmode (StPrim IntSubOp [x, StInt i])
+-- This is all just ridiculous, since it carefully undoes
+-- what mangleIndexTree has just done.
+getAmode (StMachOp MO_Nat_Sub [x, StInt i])
= getNewRegNCG PtrRep `thenNat` \ tmp ->
getRegister x `thenNat` \ register ->
let
in
returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-getAmode (StPrim IntAddOp [x, StInt i])
+getAmode (StMachOp MO_Nat_Add [x, StInt i])
| maybeToBool imm
= returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
where
imm = maybeImm x
imm__2 = case imm of Just x -> x
-getAmode (StPrim IntAddOp [x, StInt i])
+getAmode (StMachOp MO_Nat_Add [x, StInt i])
= getNewRegNCG PtrRep `thenNat` \ tmp ->
getRegister x `thenNat` \ register ->
let
in
returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
+getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
| shift == 0 || shift == 1 || shift == 2 || shift == 3
= getNewRegNCG PtrRep `thenNat` \ tmp1 ->
getNewRegNCG IntRep `thenNat` \ tmp2 ->
Set up a condition code for a conditional branch.
\begin{code}
-getCondCode :: StixTree -> NatM CondCode
+getCondCode :: StixExpr -> NatM CondCode
#if alpha_TARGET_ARCH
getCondCode = panic "MachCode.getCondCode: not on Alphas"
#if i386_TARGET_ARCH || sparc_TARGET_ARCH
-- yes, they really do seem to want exactly the same!
-getCondCode (StPrim primop [x, y])
- = case primop of
- CharGtOp -> condIntCode GTT x y
- CharGeOp -> condIntCode GE x y
- CharEqOp -> condIntCode EQQ x y
- CharNeOp -> condIntCode NE x y
- CharLtOp -> condIntCode LTT x y
- CharLeOp -> condIntCode LE x y
+getCondCode (StMachOp mop [x, y])
+ = case mop of
+ MO_32U_Gt -> condIntCode GTT x y
+ MO_32U_Ge -> condIntCode GE x y
+ MO_32U_Eq -> condIntCode EQQ x y
+ MO_32U_Ne -> condIntCode NE x y
+ MO_32U_Lt -> condIntCode LTT x y
+ MO_32U_Le -> condIntCode LE x y
- IntGtOp -> condIntCode GTT x y
- IntGeOp -> condIntCode GE x y
- IntEqOp -> condIntCode EQQ x y
- IntNeOp -> condIntCode NE x y
- IntLtOp -> condIntCode LTT x y
- IntLeOp -> condIntCode LE x y
-
- WordGtOp -> condIntCode GU x y
- WordGeOp -> condIntCode GEU x y
- WordEqOp -> condIntCode EQQ x y
- WordNeOp -> condIntCode NE x y
- WordLtOp -> condIntCode LU x y
- WordLeOp -> condIntCode LEU x y
-
- AddrGtOp -> condIntCode GU x y
- AddrGeOp -> condIntCode GEU x y
- AddrEqOp -> condIntCode EQQ x y
- AddrNeOp -> condIntCode NE x y
- AddrLtOp -> condIntCode LU x y
- AddrLeOp -> condIntCode LEU x y
-
- FloatGtOp -> condFltCode GTT x y
- FloatGeOp -> condFltCode GE x y
- FloatEqOp -> condFltCode EQQ x y
- FloatNeOp -> condFltCode NE x y
- FloatLtOp -> condFltCode LTT x y
- FloatLeOp -> condFltCode LE x y
-
- DoubleGtOp -> condFltCode GTT x y
- DoubleGeOp -> condFltCode GE x y
- DoubleEqOp -> condFltCode EQQ x y
- DoubleNeOp -> condFltCode NE x y
- DoubleLtOp -> condFltCode LTT x y
- DoubleLeOp -> condFltCode LE x y
+ MO_Nat_Eq -> condIntCode EQQ x y
+ MO_Nat_Ne -> condIntCode NE x y
+
+ MO_NatS_Gt -> condIntCode GTT x y
+ MO_NatS_Ge -> condIntCode GE x y
+ MO_NatS_Lt -> condIntCode LTT x y
+ MO_NatS_Le -> condIntCode LE x y
+
+ MO_NatU_Gt -> condIntCode GU x y
+ MO_NatU_Ge -> condIntCode GEU x y
+ MO_NatU_Lt -> condIntCode LU x y
+ MO_NatU_Le -> condIntCode LEU x y
+
+ MO_Flt_Gt -> condFltCode GTT x y
+ MO_Flt_Ge -> condFltCode GE x y
+ MO_Flt_Eq -> condFltCode EQQ x y
+ MO_Flt_Ne -> condFltCode NE x y
+ MO_Flt_Lt -> condFltCode LTT x y
+ MO_Flt_Le -> condFltCode LE x y
+
+ MO_Dbl_Gt -> condFltCode GTT x y
+ MO_Dbl_Ge -> condFltCode GE x y
+ MO_Dbl_Eq -> condFltCode EQQ x y
+ MO_Dbl_Ne -> condFltCode NE x y
+ MO_Dbl_Lt -> condFltCode LTT x y
+ MO_Dbl_Le -> condFltCode LE x y
+
+ other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
#endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
\end{code}
passed back up the tree.
\begin{code}
-condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
+condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
#if alpha_TARGET_ARCH
condIntCode = panic "MachCode.condIntCode: not on Alphas"
hand side is forced into a fixed register (e.g. the result of a call).
\begin{code}
-assignIntCode, assignFltCode
- :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
+assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
+assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
+
+assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
+assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
#if alpha_TARGET_ARCH
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
--- Destination of an assignment can only be reg or mem.
--- This is the mem case.
-assignIntCode pk (StInd _ dst) src
- = getAmode dst `thenNat` \ amode ->
+-- non-FP assignment to memory
+assignMem_IntCode pk addr src
+ = getAmode addr `thenNat` \ amode ->
get_op_RI src `thenNat` \ (codesrc, opsrc) ->
getNewRegNCG PtrRep `thenNat` \ tmp ->
let
returnNat code
where
get_op_RI
- :: StixTree
+ :: StixExpr
-> NatM (InstrBlock,Operand) -- code, operator
get_op_RI op
returnNat (code, OpReg reg)
-- Assign; dst is a reg, rhs is mem
-assignIntCode pk dst (StInd pks src)
+assignReg_IntCode pk reg (StInd pks src)
= getNewRegNCG PtrRep `thenNat` \ tmp ->
getAmode src `thenNat` \ amode ->
- getRegister dst `thenNat` \ reg_dst ->
+ getRegisterReg reg `thenNat` \ reg_dst ->
let
c_addr = amodeCode amode
am_addr = amodeAddr amode
-
- 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
Lu -> MOV L
- code | isNilOL c_dst
- = c_addr `snocOL`
+ code = c_addr `snocOL`
opc (OpAddr am_addr) (OpReg r_dst)
- | otherwise
- = panic "assignIntCode(x86): bad dst(2)"
in
returnNat code
-- dst is a reg, but src could be anything
-assignIntCode pk dst src
- = getRegister dst `thenNat` \ registerd ->
+assignReg_IntCode pk reg src
+ = getRegisterReg reg `thenNat` \ registerd ->
getRegister src `thenNat` \ registers ->
getNewRegNCG IntRep `thenNat` \ tmp ->
let
r_dst = registerName registerd tmp
- c_dst = registerCode registerd tmp -- should be empty
r_src = registerName registers r_dst
c_src = registerCode registers r_dst
- code | isNilOL c_dst
- = c_src `snocOL`
+ code = c_src `snocOL`
MOV L (OpReg r_src) (OpReg r_dst)
- | otherwise
- = panic "assignIntCode(x86): bad dst(3)"
in
returnNat code
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
--- dst is memory
-assignFltCode pk (StInd pk_dst addr) src
- | pk /= pk_dst
- = panic "assignFltCode(x86): src/ind sz mismatch"
- | otherwise
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src
= getRegister src `thenNat` \ reg_src ->
getRegister addr `thenNat` \ reg_addr ->
getNewRegNCG pk `thenNat` \ tmp_src ->
in
returnNat code
--- dst must be a (FP) register
-assignFltCode pk dst src
- = getRegister dst `thenNat` \ reg_dst ->
+-- Floating point assignment to a register/temporary
+assignReg_FltCode pk reg src
+ = getRegisterReg reg `thenNat` \ reg_dst ->
getRegister src `thenNat` \ reg_src ->
getNewRegNCG pk `thenNat` \ tmp ->
let
r_dst = registerName reg_dst tmp
- c_dst = registerCode reg_dst tmp -- should be empty
-
r_src = registerName reg_src r_dst
c_src = registerCode reg_src r_dst
- code | isNilOL c_dst
- = if isFixed reg_src
+ code = if isFixed reg_src
then c_src `snocOL` GMOV r_src r_dst
else c_src
- | otherwise
- = panic "assignFltCode(x86): lhs is not mem or reg"
in
returnNat code
register allocator.
\begin{code}
-genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
+genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
#if alpha_TARGET_ARCH
\begin{code}
genCondJump
:: CLabel -- the branch target
- -> StixTree -- the condition on which to branch
+ -> StixExpr -- the condition on which to branch
-> NatM InstrBlock
#if alpha_TARGET_ARCH
:: FAST_STRING -- function to call
-> CCallConv
-> PrimRep -- type of the result
- -> [StixTree] -- arguments (of mixed type)
+ -> [StixExpr] -- arguments (of mixed type)
-> NatM InstrBlock
#if alpha_TARGET_ARCH
arg_size _ = 4
------------
- get_call_arg :: StixTree{-current argument-}
+ get_call_arg :: StixExpr{-current argument-}
-> NatM (Int, InstrBlock) -- argsz, code
get_call_arg arg
)
------------
get_op
- :: StixTree
+ :: StixExpr
-> NatM (InstrBlock, Reg, Size) -- code, reg, size
get_op op
register allocator.
\begin{code}
-condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
+condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
#if alpha_TARGET_ARCH
condIntReg = panic "MachCode.condIntReg (not on Alpha)"
-> Maybe (Operand -> Operand -> Instr)
,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
,)))
- -> StixTree -> StixTree -- the two arguments
+ -> StixExpr -> StixExpr -- the two arguments
-> NatM Register
trivialFCode
,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
,)))
- -> StixTree -> StixTree -- the two arguments
+ -> StixExpr -> StixExpr -- the two arguments
-> NatM Register
trivialUCode
,IF_ARCH_i386 ((Operand -> Instr)
,IF_ARCH_sparc((RI -> Reg -> Instr)
,)))
- -> StixTree -- the one argument
+ -> StixExpr -- the one argument
-> NatM Register
trivialUFCode
,IF_ARCH_i386 ((Reg -> Reg -> Instr)
,IF_ARCH_sparc((Reg -> Reg -> Instr)
,)))
- -> StixTree -- the one argument
+ -> StixExpr -- the one argument
-> NatM Register
#if alpha_TARGET_ARCH
between the integer and the floating point register sets.
\begin{code}
-coerceIntCode :: PrimRep -> StixTree -> NatM Register
-coerceFltCode :: StixTree -> NatM Register
+coerceIntCode :: PrimRep -> StixExpr -> NatM Register
+coerceFltCode :: StixExpr -> NatM Register
-coerceInt2FP :: PrimRep -> StixTree -> NatM Register
-coerceFP2Int :: StixTree -> NatM Register
+coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
+coerceFP2Int :: StixExpr -> NatM Register
coerceIntCode pk x
= getRegister x `thenNat` \ register ->
Integer to character conversion.
\begin{code}
-chrCode :: StixTree -> NatM Register
+chrCode :: StixExpr -> NatM Register
#if alpha_TARGET_ARCH
import AbsCUtils ( magicIdPrimRep )
import CLabel ( CLabel, isAsmTemp )
import Literal ( mkMachInt, Literal(..) )
-import MachRegs ( stgReg, callerSaves, RegLoc(..),
- Imm(..), Reg(..),
- MachRegsAddr(..)
+import MachRegs ( callerSaves,
+ get_MagicId_addr, get_MagicId_reg_or_addr,
+ Imm(..), Reg(..), MachRegsAddr(..)
# if sparc_TARGET_ARCH
,fp, sp
# endif
)
import PrimRep ( PrimRep(..) )
-import Stix ( StixTree(..), StixReg(..), CodeSegment, DestInfo(..) )
+import Stix ( StixStmt(..), StixExpr(..), StixReg(..),
+ CodeSegment, DestInfo(..) )
import Panic ( panic )
import GlaExts ( word2Int#, int2Word#, shiftRL#, and#, (/=#) )
import Outputable ( pprPanic, ppr, showSDoc )
import IOExts ( trace )
import Config ( cLeadingUnderscore )
import FastTypes
+
+import Maybe ( catMaybes )
\end{code}
\begin{code}
(@volatileRestores@ used only for wrapper-hungry PrimOps.)
\begin{code}
-volatileSaves, volatileRestores :: [MagicId] -> [StixTree]
+volatileSaves, volatileRestores :: [MagicId] -> [StixStmt]
+
+volatileSaves = volatileSavesOrRestores True
+volatileRestores = volatileSavesOrRestores False
save_cands = [BaseReg,Sp,Su,SpLim,Hp,HpLim]
restore_cands = save_cands
-volatileSaves vols
- = map save ((filter callerSaves) (save_cands ++ vols))
- where
- save x = StAssign (magicIdPrimRep x) loc reg
- where
- reg = StReg (StixMagicId x)
- loc = case stgReg x of
- Save loc -> loc
- Always _ -> panic "volatileSaves"
-
-volatileRestores vols
- = map restore ((filter callerSaves) (restore_cands ++ vols))
- where
- restore x = StAssign (magicIdPrimRep x) reg loc
- where
- reg = StReg (StixMagicId x)
- loc = case stgReg x of
- Save loc -> loc
- Always _ -> panic "volatileRestores"
+volatileSavesOrRestores do_saves vols
+ = catMaybes (map mkCode vols)
+ where
+ mkCode mid
+ | not (callerSaves mid)
+ = Nothing
+ | otherwise -- must be callee-saves ...
+ = case get_MagicId_reg_or_addr mid of
+ -- If stored in BaseReg, we ain't interested
+ Right baseRegAddr
+ -> Nothing
+ Left (RealReg rrno)
+ -- OK, it's callee-saves, and in a real reg (rrno).
+ -- We have to cook up some transfer code.
+ {- Note that the use of (StixMagicId mid) here is a bit subtle.
+ Here, we only create those for MagicIds which are stored in
+ a real reg on this arch -- the preceding case on the result
+ of get_MagicId_reg_or_addr guarantees this. Later, when
+ selecting insns, that means these assignments are sure to turn
+ into real reg-to-mem or mem-to-reg moves, rather than being
+ pointless moves from some address in the reg-table
+ back to itself.-}
+ | do_saves
+ -> Just (StAssignMem rep addr
+ (StReg (StixMagicId mid)))
+ | otherwise
+ -> Just (StAssignReg rep (StixMagicId mid)
+ (StInd rep addr))
+ where
+ rep = magicIdPrimRep mid
+ addr = get_MagicId_addr mid
\end{code}
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
| NE
| NEG
| POS
+ | CARRY
+ | OFLO
#endif
#if sparc_TARGET_ARCH
= ALWAYS -- What's really used? ToDo
primRepToSize ForeignObjRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, )))
primRepToSize BCORep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, )))
primRepToSize StablePtrRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, )))
+primRepToSize StableNameRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, )))
primRepToSize ThreadIdRep = IF_ARCH_alpha(Q, IF_ARCH_i386(L, IF_ARCH_sparc(W, )))
primRepToSize Word64Rep = primRepToSize_fail "Word64Rep"
| ADD Size Operand Operand
| SUB Size Operand Operand
- | IMUL Size Operand Operand
+ | IMUL Size Operand Operand -- signed int mul
+ | MUL Size Operand Operand -- unsigned int mul
-- Quotient and remainder. SEE comment above -- these are not
-- real x86 insns; instead they are expanded when printed
-- into a sequence of real insns.
- | IQUOT Size Operand Operand
- | IREM Size Operand Operand
+ | IQUOT Size Operand Operand -- signed quotient
+ | IREM Size Operand Operand -- signed remainder
+ | QUOT Size Operand Operand -- unsigned quotient
+ | REM Size Operand Operand -- unsigned remainder
-- Simple bit-twiddling.
| GLDZ Reg -- dst(fpreg)
| GLD1 Reg -- dst(fpreg)
- | GFTOD Reg Reg -- src(fpreg), dst(fpreg)
| GFTOI Reg Reg -- src(fpreg), dst(intreg)
-
- | GDTOF Reg Reg -- src(fpreg), dst(fpreg)
| GDTOI Reg Reg -- src(fpreg), dst(intreg)
| GITOF Reg Reg -- src(intreg), dst(fpreg)
= case instr of
GMOV _ _ -> True; GLD _ _ _ -> True; GST _ _ _ -> True;
GLDZ _ -> True; GLD1 _ -> True;
- GFTOD _ _ -> True; GFTOI _ _ -> True;
- GDTOF _ _ -> True; GDTOI _ _ -> True;
+ GFTOI _ _ -> True; GDTOI _ _ -> True;
GITOF _ _ -> True; GITOD _ _ -> True;
GADD _ _ _ _ -> True; GDIV _ _ _ _ -> True
GSUB _ _ _ _ -> True; GMUL _ _ _ _ -> True
Imm(..),
MachRegsAddr(..),
- RegLoc(..),
addrOffset,
baseRegOffset,
freeReg,
getNewRegNCG,
mkVReg,
- magicIdRegMaybe,
- saveLoc,
+ get_MagicId_reg_or_addr,
+ get_MagicId_addr,
+ get_Regtable_addr_from_offset,
spRel,
- stgReg,
- regTableEntry,
strImmLit
#if alpha_TARGET_ARCH
#include "HsVersions.h"
import AbsCSyn ( MagicId(..) )
-import AbsCUtils ( magicIdPrimRep )
import CLabel ( CLabel, mkMainRegTableLabel )
-import PrimOp ( PrimOp(..) )
+import MachOp ( MachOp(..) )
import PrimRep ( PrimRep(..), isFloatingRep )
-import Stix ( StixTree(..), StixReg(..),
+import Stix ( StixExpr(..), StixReg(..),
getUniqueNat, returnNat, thenNat, NatM )
import Unique ( mkPseudoUnique2, Uniquable(..), Unique )
import Pretty
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-@stgReg@: we map STG registers onto appropriate Stix Trees. First, we
-handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@.
-The rest are either in real machine registers or stored as offsets
-from BaseReg.
+@stgReg@: we map STG registers onto appropriate Stix Trees. Either
+they map to real machine registers or stored as offsets from BaseReg.
+Given a MagicId, get_MagicId_reg_or_addr produces either the real
+register it is in, on this platform, or a StixExpr denoting the
+address in the register table holding it. get_MagicId_addr always
+produces the register table address for it.
\begin{code}
-data RegLoc = Save StixTree | Always StixTree
-\end{code}
-
-Trees for register save locations:
-\begin{code}
-saveLoc :: MagicId -> StixTree
-saveLoc reg = case (stgReg reg) of {Always loc -> loc; Save loc -> loc}
-\end{code}
-
-\begin{code}
-stgReg :: MagicId -> RegLoc
-stgReg BaseReg
- = case magicIdRegMaybe BaseReg of
- Nothing -> Always (StCLbl mkMainRegTableLabel)
- Just _ -> Save (StCLbl mkMainRegTableLabel)
-stgReg x
- = case magicIdRegMaybe x of
- Just _ -> Save stix
- Nothing -> Always stix
- where
- stix = regTableEntry (magicIdPrimRep x) (baseRegOffset x)
-
-regTableEntry :: PrimRep -> Int -> StixTree
-regTableEntry rep offset
- = StInd rep (StPrim IntAddOp
- [baseLoc, StInt (toInteger (offset*BYTES_PER_WORD))])
- where
- baseLoc = case (magicIdRegMaybe BaseReg) of
- Just _ -> StReg (StixMagicId BaseReg)
- Nothing -> StCLbl mkMainRegTableLabel
+get_MagicId_reg_or_addr :: MagicId -> Either Reg StixExpr
+get_MagicId_addr :: MagicId -> StixExpr
+get_Regtable_addr_from_offset :: Int -> StixExpr
+
+get_MagicId_reg_or_addr mid
+ = case magicIdRegMaybe mid of
+ Just rr -> Left rr
+ Nothing -> Right (get_MagicId_addr mid)
+
+get_MagicId_addr BaseReg
+ = panic "MachRegs.get_MagicId_addr of BaseReg"
+get_MagicId_addr mid
+ = get_Regtable_addr_from_offset (baseRegOffset mid)
+
+get_Regtable_addr_from_offset offset_in_words
+ = case magicIdRegMaybe BaseReg of
+ Nothing -> panic "MachRegs.get_Regtable_addr_from_offset: BaseReg not in a reg"
+ Just rr -> StMachOp MO_Nat_Add
+ [StReg (StixMagicId BaseReg),
+ StInt (toInteger (offset_in_words*BYTES_PER_WORD))]
\end{code}
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
LTT -> SLIT("l"); LE -> SLIT("le");
LEU -> SLIT("be"); NE -> SLIT("ne");
NEG -> SLIT("s"); POS -> SLIT("ns");
+ CARRY -> SLIT("c"); OFLO -> SLIT("o");
ALWAYS -> SLIT("mp") -- hack
#endif
#if sparc_TARGET_ARCH
pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst
pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
+{- A hack. The Intel documentation says that "The two and three
+ operand forms [of IMUL] may also be used with unsigned operands
+ because the lower half of the product is the same regardless if
+ (sic) the operands are signed or unsigned. The CF and OF flags,
+ however, cannot be used to determine if the upper half of the
+ result is non-zero." So there.
+-}
+pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2
+
pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst
pprInstr (OR size src dst) = pprSizeOpOp SLIT("or") size src dst
pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst
pprInstr (JMP dsts op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
pprInstr (CALL imm) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
-pprInstr (IQUOT sz src dst) = pprInstr_quotRem True sz src dst
-pprInstr (IREM sz src dst) = pprInstr_quotRem False sz src dst
+-- First bool indicates signedness; second whether quot or rem
+pprInstr (IQUOT sz src dst) = pprInstr_quotRem True True sz src dst
+pprInstr (IREM sz src dst) = pprInstr_quotRem True False sz src dst
+
+pprInstr (QUOT sz src dst) = pprInstr_quotRem False True sz src dst
+pprInstr (REM sz src dst) = pprInstr_quotRem False False sz src dst
-- Simulating a flat register set on the x86 FP stack is tricky.
-- you have to free %st(7) before pushing anything on the FP reg stack
pprInstr g@(GLD1 dst)
= pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1])
-pprInstr g@(GFTOD src dst)
- = pprG g bogus
pprInstr g@(GFTOI src dst)
- = pprG g bogus
-
-pprInstr g@(GDTOF src dst)
- = pprG g bogus
+ = pprInstr (GDTOI src dst)
pprInstr g@(GDTOI src dst)
- = pprG g bogus
+ = pprG g (hcat [gtab, text "subl $4, %esp ; ",
+ gpush src 0, gsemi, text "fistpl 0(%esp) ; popl ",
+ pprReg L dst])
pprInstr g@(GITOF src dst)
= pprInstr (GITOD src dst)
]
-pprInstr_quotRem isQuot sz src dst
+pprInstr_quotRem signed isQuot sz src dst
| case sz of L -> False; _ -> True
= panic "pprInstr_quotRem: dunno how to do non-32bit operands"
| otherwise
(text "\t# BEGIN " <> fakeInsn),
(text "\tpushl $0; pushl %eax; pushl %edx; pushl " <> pprOperand sz src),
(text "\tmovl " <> pprOperand sz dst <> text ",%eax; xorl %edx,%edx; cltd"),
- (text "\tdivl 0(%esp); movl " <> text resReg <> text ",12(%esp)"),
+ (x86op <> text " 0(%esp); movl " <> text resReg <> text ",12(%esp)"),
(text "\tpopl %edx; popl %edx; popl %eax; popl " <> pprOperand sz dst),
(text "\t# END " <> fakeInsn)
]
where
+ x86op = if signed then text "\tidivl" else text "\tdivl"
resReg = if isQuot then "%eax" else "%edx"
- opStr = if isQuot then "IQUOT" else "IREM"
- fakeInsn = text opStr <+> pprOperand sz src <> char ',' <+> pprOperand sz dst
+ opStr | signed = if isQuot then "IQUOT" else "IREM"
+ | not signed = if isQuot then "QUOT" else "REM"
+ fakeInsn = text opStr <+> pprOperand sz src
+ <> char ',' <+> pprOperand sz dst
--------------------------
-- coerce %st(0) to the specified size
gcoerceto DF = empty
-gcoerceto F = text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
+gcoerceto F = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
gpush reg offset
= hcat [text "ffree %st(7) ; fld ", greg reg offset]
pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") DF dst
pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") DF dst
-pprGInstr (GFTOD src dst) = pprSizeSizeRegReg SLIT("gftod") F DF src dst
pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L src dst
-
-pprGInstr (GDTOF src dst) = pprSizeSizeRegReg SLIT("gdtof") DF F src dst
pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst
pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F src dst
ADD sz src dst -> usageRM src dst
SUB sz src dst -> usageRM src dst
IMUL sz src dst -> usageRM src dst
+ MUL sz src dst -> usageRM src dst
IQUOT sz src dst -> usageRM src dst
IREM sz src dst -> usageRM src dst
+ QUOT sz src dst -> usageRM src dst
+ REM sz src dst -> usageRM src dst
AND sz src dst -> usageRM src dst
OR sz src dst -> usageRM src dst
XOR sz src dst -> usageRM src dst
GLDZ dst -> mkRU [] [dst]
GLD1 dst -> mkRU [] [dst]
- GFTOD src dst -> mkRU [src] [dst]
GFTOI src dst -> mkRU [src] [dst]
-
- GDTOF src dst -> mkRU [src] [dst]
GDTOI src dst -> mkRU [src] [dst]
GITOF src dst -> mkRU [src] [dst]
ADD sz src dst -> patch2 (ADD sz) src dst
SUB sz src dst -> patch2 (SUB sz) src dst
IMUL sz src dst -> patch2 (IMUL sz) src dst
+ MUL sz src dst -> patch2 (MUL sz) src dst
IQUOT sz src dst -> patch2 (IQUOT sz) src dst
IREM sz src dst -> patch2 (IREM sz) src dst
+ QUOT sz src dst -> patch2 (QUOT sz) src dst
+ REM sz src dst -> patch2 (REM sz) src dst
AND sz src dst -> patch2 (AND sz) src dst
OR sz src dst -> patch2 (OR sz) src dst
XOR sz src dst -> patch2 (XOR sz) src dst
GLDZ dst -> GLDZ (env dst)
GLD1 dst -> GLD1 (env dst)
- GFTOD src dst -> GFTOD (env src) (env dst)
GFTOI src dst -> GFTOI (env src) (env dst)
-
- GDTOF src dst -> GDTOF (env src) (env dst)
GDTOI src dst -> GDTOI (env src) (env dst)
GITOF src dst -> GITOF (env src) (env dst)
\begin{code}
module Stix (
- CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
- pprStixTrees, pprStixTree, ppStixReg,
- stixCountTempUses, stixSubst,
+ CodeSegment(..), StixReg(..), StixExpr(..), StixVReg(..),
+ StixStmt(..), mkStAssign, StixStmtList,
+ pprStixStmts, pprStixStmt, pprStixExpr, pprStixReg,
+ stixStmt_CountTempUses, stixStmt_Subst,
+ liftStrings,
DestInfo(..), hasDestInfo,
stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
import ForeignCall ( CCallConv )
import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
import PrimRep ( PrimRep(..) )
-import PrimOp ( PrimOp )
+import MachOp ( MachOp(..), pprMachOp )
import Unique ( Unique )
import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
UniqSM, thenUs, returnUs, getUniqueUs )
+import Maybes ( Maybe012(..), maybe012ToList )
import Outputable
import FastTypes
\end{code}
-Here is the tag at the nodes of our @StixTree@. Notice its
-relationship with @PrimOp@ in prelude/PrimOp.
+Two types, StixStmt and StixValue, define Stix.
\begin{code}
-data StixTree
- = -- Segment (text or data)
- StSegment CodeSegment
-
- -- We can tag the leaves with constants/immediates.
-
- | StInt Integer -- ** add Kind at some point
- | StFloat Rational
- | StDouble Rational
- | StString FAST_STRING
- | StCLbl CLabel -- labels that we might index into
-
- -- Abstract registers of various kinds
-
- | StReg StixReg
+-- Non-value trees; ones executed for their side-effect.
+data StixStmt
- -- A typed offset from a base location
-
- | StIndex PrimRep StixTree StixTree -- kind, base, offset
+ = -- Directive for the assembler to change segment
+ StSegment CodeSegment
- -- An indirection from an address to its contents.
+ -- Assembly-language comments
+ | StComment FAST_STRING
- | StInd PrimRep StixTree
+ -- Assignments are typed to determine size and register placement.
+ -- Assign a value to a StixReg
+ | StAssignReg PrimRep StixReg StixExpr
- -- Assignment is typed to determine size and register placement
+ -- Assign a value to memory. First tree indicates the address to be
+ -- assigned to, so there is an implicit dereference here.
+ | StAssignMem PrimRep StixExpr StixExpr -- dst, src
- | StAssign PrimRep StixTree StixTree -- dst, src
+ -- Do a machine op which generates multiple values, and assign
+ -- the results to the lvalues stated here.
+ | StAssignMachOp (Maybe012 StixVReg) MachOp [StixExpr]
-- A simple assembly label that we might jump to.
-
| StLabel CLabel
-- A function header and footer
-
| StFunBegin CLabel
| StFunEnd CLabel
-- the exact targets to be attached, so that the allocator can
-- easily construct the exact flow edges leaving this insn.
-- Dynamic targets are allowed.
-
- | StJump DestInfo StixTree
+ | StJump DestInfo StixExpr
-- A fall-through, from slow to fast
-
| StFallThrough CLabel
-- A conditional jump. This instruction can be non-terminal :-)
-- Only static, local, forward labels are allowed
-
- | StCondJump CLabel StixTree
+ | StCondJump CLabel StixExpr
-- Raw data (as in an info table).
+ | StData PrimRep [StixExpr]
+ -- String which has been lifted to the top level (sigh).
+ | StDataString FAST_STRING
+
+ -- A value computed only for its side effects; result is discarded
+ -- (A handy trapdoor to allow CCalls with no results to appear as
+ -- statements).
+ | StVoidable StixExpr
+
+
+-- Helper fn to make Stix assignment statements where the
+-- lvalue masquerades as a StixExpr. A kludge that should
+-- be done away with.
+mkStAssign :: PrimRep -> StixExpr -> StixExpr -> StixStmt
+mkStAssign rep (StReg reg) rhs
+ = StAssignReg rep reg rhs
+mkStAssign rep (StInd rep' addr) rhs
+ | rep `isCloseEnoughTo` rep'
+ = StAssignMem rep addr rhs
+ | otherwise
+ = --pprPanic "Stix.mkStAssign: mismatched reps" (ppr rep <+> ppr rep')
+ --trace ("Stix.mkStAssign: mismatched reps: " ++ showSDoc (ppr rep <+> ppr rep')) (
+ StAssignMem rep addr rhs
+ --)
+ where
+ isCloseEnoughTo r1 r2
+ = r1 == r2 || (wordIsh r1 && wordIsh r2)
+ wordIsh rep
+ = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep,
+ RetRep, ArrayRep, PrimPtrRep, StableNameRep, BCORep]
+ -- determined by looking at PrimRep.showPrimRep
+
+-- Stix trees which denote a value.
+data StixExpr
+ = -- Literals
+ StInt Integer -- ** add Kind at some point
+ | StFloat Rational
+ | StDouble Rational
+ | StString FAST_STRING
+ | StCLbl CLabel -- labels that we might index into
- | StData PrimRep [StixTree]
-
- -- Primitive Operations
-
- | StPrim PrimOp [StixTree]
-
- -- Calls to C functions
-
- | StCall FAST_STRING CCallConv PrimRep [StixTree]
+ -- Abstract registers of various kinds
+ | StReg StixReg
- -- A volatile memory scratch array, which is allocated
- -- relative to the stack pointer. It is an array of
- -- ptr/word/int sized things. Do not expect to be preserved
- -- beyond basic blocks or over a ccall. Current max size
- -- is 6, used in StixInteger.
+ -- A typed offset from a base location
+ | StIndex PrimRep StixExpr StixExpr -- kind, base, offset
- | StScratchWord Int
+ -- An indirection from an address to its contents.
+ | StInd PrimRep StixExpr
- -- Assembly-language comments
+ -- Primitive Operations
+ | StMachOp MachOp [StixExpr]
- | StComment FAST_STRING
+ -- Calls to C functions
+ | StCall FAST_STRING CCallConv PrimRep [StixExpr]
-- used by insnFuture in RegAllocInfo.lhs
pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
-pprStixTrees :: [StixTree] -> SDoc
-pprStixTrees ts
+pprStixStmts :: [StixStmt] -> SDoc
+pprStixStmts ts
= vcat [
- vcat (map pprStixTree ts),
+ vcat (map pprStixStmt ts),
char ' ',
char ' '
]
-pprStixTree :: StixTree -> SDoc
-pprStixTree t
+
+pprStixExpr :: StixExpr -> SDoc
+pprStixExpr t
= case t of
- StSegment cseg -> parens (ppCodeSegment cseg)
- StInt i -> parens (integer i)
+ StCLbl lbl -> pprCLabel lbl
+ StInt i -> (if i < 0 then parens else id) (integer i)
StFloat rat -> parens (text "Float" <+> rational rat)
StDouble rat -> parens (text "Double" <+> rational rat)
StString str -> parens (text "Str `" <> ptext str <> char '\'')
+ StIndex k b o -> parens (pprStixExpr b <+> char '+' <>
+ ppr k <+> pprStixExpr o)
+ StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']'
+ StReg reg -> pprStixReg reg
+ StMachOp op args -> pprMachOp op
+ <> parens (hsep (punctuate comma (map pprStixExpr args)))
+ StCall nm cc k args
+ -> parens (text "Call" <+> ptext nm <+>
+ ppr cc <+> ppr k <+>
+ hsep (map pprStixExpr args))
+
+pprStixStmt :: StixStmt -> SDoc
+pprStixStmt t
+ = case t of
+ StSegment cseg -> parens (ppCodeSegment cseg)
StComment str -> parens (text "Comment" <+> ptext str)
- StCLbl lbl -> pprCLabel lbl
- StReg reg -> ppStixReg reg
- StIndex k b o -> parens (pprStixTree b <+> char '+' <>
- ppr k <+> pprStixTree o)
- StInd k t -> ppr k <> char '[' <> pprStixTree t <> char ']'
- StAssign k d s -> pprStixTree d <> text " :=" <> ppr k
- <> text " " <> pprStixTree s
+ StAssignReg pr reg rhs
+ -> pprStixReg reg <> text " :=" <> ppr pr
+ <> text " " <> pprStixExpr rhs
+ StAssignMem pr addr rhs
+ -> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
+ <> text " :=" <> ppr pr
+ <> text " " <> pprStixExpr rhs
+ StAssignMachOp lhss mop args
+ -> parens (hcat (punctuate comma (
+ map pprStixVReg (maybe012ToList lhss)
+ )))
+ <> text " := "
+ <> pprMachOp mop
+ <> parens (hsep (punctuate comma (map pprStixExpr args)))
StLabel ll -> pprCLabel ll <+> char ':'
StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll)
- StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixTree t)
+ StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t)
StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
StCondJump l t -> parens (text "JumpC" <+> pprCLabel l
- <+> pprStixTree t)
+ <+> pprStixExpr t)
StData k ds -> parens (text "Data" <+> ppr k <+>
- hsep (map pprStixTree ds))
- StPrim op ts -> parens (text "Prim" <+> ppr op <+>
- hsep (map pprStixTree ts))
- StCall nm cc k args
- -> parens (text "Call" <+> ptext nm <+>
- ppr cc <+> ppr k <+>
- hsep (map pprStixTree args))
- StScratchWord i -> text "ScratchWord" <> parens (int i)
+ hsep (map pprStixExpr ds))
+ StDataString str -> parens (text "DataString" <+> ppr str)
+ StVoidable expr -> text "(void)" <+> pprStixExpr expr
\end{code}
Stix registers can have two forms. They {\em may} or {\em may not}
data StixReg
= StixMagicId MagicId -- Regs which are part of the abstract machine model
- | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
- -- the abstract C.
+ | StixTemp StixVReg -- "Regs" which model local variables (CTemps) in
+ -- the abstract C.
+
+pprStixReg (StixMagicId mid) = ppMId mid
+pprStixReg (StixTemp temp) = pprStixVReg temp
+
+data StixVReg
+ = StixVReg Unique PrimRep
+
+pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, ppr pr, char ')']
-ppStixReg (StixMagicId mid)
- = ppMId mid
-ppStixReg (StixTemp u pr)
- = hcat [text "Temp(", ppr u, ppr pr, char ')']
ppMId BaseReg = text "BaseReg"
together).
\begin{code}
-data CodeSegment = DataSegment | TextSegment | RoDataSegment deriving (Eq, Show)
+data CodeSegment
+ = DataSegment
+ | TextSegment
+ | RoDataSegment
+ deriving (Eq, Show)
+
ppCodeSegment = text . show
-type StixTreeList = [StixTree] -> [StixTree]
+type StixStmtList = [StixStmt] -> [StixStmt]
\end{code}
Stix Trees for STG registers:
\begin{code}
stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
- :: StixTree
-
-stgBaseReg = StReg (StixMagicId BaseReg)
-stgNode = StReg (StixMagicId node)
-stgTagReg = StReg (StixMagicId tagreg)
-stgSp = StReg (StixMagicId Sp)
-stgSu = StReg (StixMagicId Su)
-stgSpLim = StReg (StixMagicId SpLim)
-stgHp = StReg (StixMagicId Hp)
-stgHpLim = StReg (StixMagicId HpLim)
-stgHpAlloc = StReg (StixMagicId HpAlloc)
-stgCurrentTSO = StReg (StixMagicId CurrentTSO)
-stgCurrentNursery = StReg (StixMagicId CurrentNursery)
-stgR9 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 9)))
-stgR10 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 10)))
+ :: StixReg
+
+stgBaseReg = StixMagicId BaseReg
+stgNode = StixMagicId node
+stgTagReg = StixMagicId tagreg
+stgSp = StixMagicId Sp
+stgSu = StixMagicId Su
+stgSpLim = StixMagicId SpLim
+stgHp = StixMagicId Hp
+stgHpLim = StixMagicId HpLim
+stgHpAlloc = StixMagicId HpAlloc
+stgCurrentTSO = StixMagicId CurrentTSO
+stgCurrentNursery = StixMagicId CurrentNursery
+stgR9 = StixMagicId (VanillaReg WordRep (_ILIT 9))
+stgR10 = StixMagicId (VanillaReg WordRep (_ILIT 10))
getNatLabelNCG :: NatM CLabel
getNatLabelNCG
whether or not to inline the assignment's RHS at usage site(s).
\begin{code}
-stixCountTempUses :: Unique -> StixTree -> Int
-stixCountTempUses u t
- = let qq = stixCountTempUses u
+stixExpr_CountTempUses :: Unique -> StixExpr -> Int
+stixExpr_CountTempUses u t
+ = let qs = stixStmt_CountTempUses u
+ qe = stixExpr_CountTempUses u
+ qr = stixReg_CountTempUses u
in
case t of
- StReg reg
- -> case reg of
- StixTemp uu pr -> if u == uu then 1 else 0
- StixMagicId mid -> 0
-
- StIndex pk t1 t2 -> qq t1 + qq t2
- StInd pk t1 -> qq t1
- StAssign pk t1 t2 -> qq t1 + qq t2
- StJump dsts t1 -> qq t1
- StCondJump lbl t1 -> qq t1
- StData pk ts -> sum (map qq ts)
- StPrim op ts -> sum (map qq ts)
- StCall nm cconv pk ts -> sum (map qq ts)
-
- StSegment _ -> 0
+ StReg reg -> qr reg
+ StIndex pk t1 t2 -> qe t1 + qe t2
+ StInd pk t1 -> qe t1
+ StMachOp mop ts -> sum (map qe ts)
+ StCall nm cconv pk ts -> sum (map qe ts)
StInt _ -> 0
StFloat _ -> 0
StDouble _ -> 0
StString _ -> 0
StCLbl _ -> 0
- StLabel _ -> 0
+
+stixStmt_CountTempUses :: Unique -> StixStmt -> Int
+stixStmt_CountTempUses u t
+ = let qe = stixExpr_CountTempUses u
+ qr = stixReg_CountTempUses u
+ qv = stixVReg_CountTempUses u
+ in
+ case t of
+ StAssignReg pk reg rhs -> qr reg + qe rhs
+ StAssignMem pk addr rhs -> qe addr + qe rhs
+ StJump dsts t1 -> qe t1
+ StCondJump lbl t1 -> qe t1
+ StData pk ts -> sum (map qe ts)
+ StAssignMachOp lhss mop args
+ -> sum (map qv (maybe012ToList lhss)) + sum (map qe args)
+ StVoidable expr -> qe expr
+ StSegment _ -> 0
StFunBegin _ -> 0
StFunEnd _ -> 0
StFallThrough _ -> 0
- StScratchWord _ -> 0
StComment _ -> 0
+ StLabel _ -> 0
+ StDataString _ -> 0
+
+stixReg_CountTempUses u reg
+ = case reg of
+ StixTemp vreg -> stixVReg_CountTempUses u vreg
+ StixMagicId mid -> 0
+stixVReg_CountTempUses u (StixVReg uu pr)
+ = if u == uu then 1 else 0
+\end{code}
+
+If we do decide to inline a temporary binding, the following functions
+do the biz.
-stixSubst :: Unique -> StixTree -> StixTree -> StixTree
-stixSubst u new_u in_this_tree
- = stixMapUniques f in_this_tree
+\begin{code}
+stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
+stixStmt_Subst u new_u in_this_tree
+ = stixStmt_MapUniques f in_this_tree
where
- f :: Unique -> Maybe StixTree
+ f :: Unique -> Maybe StixExpr
f uu = if uu == u then Just new_u else Nothing
-stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
-stixMapUniques f t
- = let qq = stixMapUniques f
+stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
+stixExpr_MapUniques f t
+ = let qe = stixExpr_MapUniques f
+ qs = stixStmt_MapUniques f
+ qr = stixReg_MapUniques f
in
case t of
- StReg reg
- -> case reg of
- StixMagicId mid -> t
- StixTemp uu pr
- -> case f uu of
- Just xx -> xx
- Nothing -> t
-
- StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
- StInd pk t1 -> StInd pk (qq t1)
- StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
- StJump dsts t1 -> StJump dsts (qq t1)
- StCondJump lbl t1 -> StCondJump lbl (qq t1)
- StData pk ts -> StData pk (map qq ts)
- StPrim op ts -> StPrim op (map qq ts)
- StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts)
-
- StSegment _ -> t
+ StReg reg -> case qr reg of
+ Nothing -> StReg reg
+ Just xx -> xx
+ StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2)
+ StInd pk t1 -> StInd pk (qe t1)
+ StMachOp mop args -> StMachOp mop (map qe args)
+ StCall nm cconv pk ts -> StCall nm cconv pk (map qe ts)
StInt _ -> t
StFloat _ -> t
StDouble _ -> t
StString _ -> t
StCLbl _ -> t
+
+stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
+stixStmt_MapUniques f t
+ = let qe = stixExpr_MapUniques f
+ qs = stixStmt_MapUniques f
+ qr = stixReg_MapUniques f
+ qv = stixVReg_MapUniques f
+
+ doMopLhss Just0 = Just0
+ doMopLhss (Just1 r1)
+ = case qv r1 of
+ Nothing -> Just1 r1
+ other -> doMopLhss_panic
+ doMopLhss (Just2 r1 r2)
+ = case (qv r1, qv r2) of
+ (Nothing, Nothing) -> Just2 r1 r2
+ other -> doMopLhss_panic
+ -- Because the StixRegs processed by doMopLhss are lvalues, they
+ -- absolutely shouldn't be mapped to a StixExpr;
+ -- hence we panic if they do. Same deal for StAssignReg below.
+ doMopLhss_panic
+ = panic "stixStmt_MapUniques:doMopLhss"
+ in
+ case t of
+ StAssignReg pk reg rhs
+ -> case qr reg of
+ Nothing -> StAssignReg pk reg (qe rhs)
+ Just xx -> panic "stixStmt_MapUniques:StAssignReg"
+ StAssignMem pk addr rhs -> StAssignMem pk (qe addr) (qe rhs)
+ StJump dsts t1 -> StJump dsts (qe t1)
+ StCondJump lbl t1 -> StCondJump lbl (qe t1)
+ StData pk ts -> StData pk (map qe ts)
+ StVoidable expr -> StVoidable (qe expr)
+ StAssignMachOp lhss mop args
+ -> StAssignMachOp (doMopLhss lhss) mop (map qe args)
+ StSegment _ -> t
StLabel _ -> t
StFunBegin _ -> t
StFunEnd _ -> t
StFallThrough _ -> t
- StScratchWord _ -> t
StComment _ -> t
+ StDataString _ -> t
+
+
+stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
+stixReg_MapUniques f reg
+ = case reg of
+ StixMagicId mid -> Nothing
+ StixTemp vreg -> stixVReg_MapUniques f vreg
+
+stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
+stixVReg_MapUniques f (StixVReg uu pr)
+ = f uu
+\end{code}
+
+\begin{code}
+-- 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 :: [StixStmt] -> UniqSM [StixStmt]
+liftStrings stmts
+ = liftStrings_wrk stmts [] []
+
+liftStrings_wrk :: [StixStmt] -- originals
+ -> [StixStmt] -- (reverse) originals with strings lifted out
+ -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
+ -> UniqSM [StixStmt]
+
+-- First, examine the original trees and lift out strings in top-level StDatas.
+liftStrings_wrk (st:sts) acc_stix acc_strs
+ = case st of
+ StData sz datas
+ -> lift datas acc_strs `thenUs` \ (datas_done, acc_strs1) ->
+ liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
+ other
+ -> liftStrings_wrk sts (other:acc_stix) acc_strs
+ where
+ -- Handle a top-level StData
+ lift [] acc_strs = returnUs ([], acc_strs)
+ lift (d:ds) acc_strs
+ = lift ds acc_strs `thenUs` \ (ds_done, acc_strs1) ->
+ case d of
+ StString s
+ -> getUniqueUs `thenUs` \ unq ->
+ let lbl = mkAsmTempLabel unq in
+ returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
+ other
+ -> returnUs (other:ds_done, acc_strs1)
+
+-- When we've run out of original trees, emit the lifted strings.
+liftStrings_wrk [] acc_stix acc_strs
+ = returnUs (reverse acc_stix ++ concatMap f acc_strs)
+ where
+ f (lbl,str) = [StSegment RoDataSegment,
+ StLabel lbl,
+ StDataString str,
+ StSegment TextSegment]
\end{code}
+The NCG's monad.
+
\begin{code}
data NatM_State = NatM_State UniqSupply Int
type NatM result = NatM_State -> (result, NatM_State)
\begin{code}
genCodeInfoTable
:: AbstractC
- -> UniqSM StixTreeList
+ -> UniqSM StixStmtList
genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr)
= returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs)
-> C_SRT
-> Int
-> Bool -- must include SRT field (i.e. it's a vector)
- -> UniqSM StixTreeList
+ -> UniqSM StixStmtList
genBitmapInfoTable liveness srt closure_type include_srt
= returnUs (\xs -> StData PtrRep table : xs)
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
-
-\begin{code}
-module StixInteger (
- gmpCompare,
- gmpCompareInt,
- gmpInteger2Int,
- gmpInteger2Word,
- gmpNegate
- ) where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} StixPrim ( amodeToStix )
-
-import AbsCSyn hiding (spRel) -- bits and bobs..
-import ForeignCall ( CCallConv(..) )
-import PrimOp ( PrimOp(..) )
-import PrimRep ( PrimRep(..) )
-import Stix ( StixTree(..), StixTreeList, arrWordsHS )
-import UniqSupply ( returnUs, UniqSM )
-\end{code}
-
-Although gmpCompare doesn't allocate space, it does temporarily use
-some space just beyond the heap pointer. This is safe, because the
-enclosing routine has already guaranteed that this space will be
-available. (See ``primOpHeapRequired.'')
-
-\begin{code}
-stgArrWords__words :: StixTree -> StixTree
-stgArrWords__BYTE_ARR_CTS :: StixTree -> StixTree
-
-stgArrWords__BYTE_ARR_CTS arr
- = StIndex WordRep arr arrWordsHS
-stgArrWords__words arr
- = case arrWordsHS of
- StInt i -> StInd WordRep (StIndex PtrRep arr (StInt (i-1)))
-
-gmpCompare
- :: CAddrMode -- result (boolean)
- -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode)
- -- alloc hp + 2 arguments (2 parts each)
- -> UniqSM StixTreeList
-
-gmpCompare res args@(csa1,cda1, csa2,cda2)
- = let
- result = amodeToStix res
- sa1 = amodeToStix csa1
- sa2 = amodeToStix csa2
- aa1 = stgArrWords__words (amodeToStix cda1)
- aa2 = stgArrWords__words (amodeToStix cda2)
- da1 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1)
- da2 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda2)
-
- (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct scratch2 (aa2,sa2,da2)
- mpz_cmp = StCall SLIT("__gmpz_cmp") CCallConv IntRep [scratch1, scratch2]
- r1 = StAssign IntRep result mpz_cmp
- in
- returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
-
-
-gmpCompareInt
- :: CAddrMode -- result (boolean)
- -> (CAddrMode,CAddrMode,CAddrMode)
- -> UniqSM StixTreeList -- alloc hp + 1 arg (??)
-
-gmpCompareInt res args@(csa1,cda1, cai)
- = let
- result = amodeToStix res
- sa1 = amodeToStix csa1
- aa1 = stgArrWords__words (amodeToStix cda1)
- da1 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1)
- ai = amodeToStix cai
- (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1)
- mpz_cmp_si = StCall SLIT("__gmpz_cmp_si") CCallConv IntRep [scratch1, ai]
- r1 = StAssign IntRep result mpz_cmp_si
- in
- returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
-\end{code}
-
-\begin{code}
-gmpInteger2Int
- :: CAddrMode -- result
- -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts)
- -> UniqSM StixTreeList
-
-gmpInteger2Int res args@(csa,cda)
- = let
- result = amodeToStix res
- sa = amodeToStix csa
- aa = stgArrWords__words (amodeToStix cda)
- da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda)
-
- (a1,a2,a3) = toStruct scratch1 (aa,sa,da)
- mpz_get_si = StCall SLIT("__gmpz_get_si") CCallConv IntRep [scratch1]
- r1 = StAssign IntRep result mpz_get_si
- in
- returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
-
-gmpInteger2Word
- :: CAddrMode -- result
- -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts)
- -> UniqSM StixTreeList
-
-gmpInteger2Word res args@(csa,cda)
- = let
- result = amodeToStix res
- sa = amodeToStix csa
- aa = stgArrWords__words (amodeToStix cda)
- da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda)
-
- (a1,a2,a3) = toStruct scratch1 (aa,sa,da)
- mpz_get_ui = StCall SLIT("__gmpz_get_ui") CCallConv IntRep [scratch1]
- r1 = StAssign WordRep result mpz_get_ui
- in
- returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
-
-gmpNegate
- :: (CAddrMode,CAddrMode) -- result
- -> (CAddrMode,CAddrMode) -- argument (2 parts)
- -> UniqSM StixTreeList
-
-gmpNegate (rcs, rcd) args@(cs, cd)
- = let
- s = amodeToStix cs
- a = stgArrWords__words (amodeToStix cd)
- d = stgArrWords__BYTE_ARR_CTS (amodeToStix cd)
- rs = amodeToStix rcs
- ra = stgArrWords__words (amodeToStix rcd)
- rd = stgArrWords__BYTE_ARR_CTS (amodeToStix rcd)
- a1 = StAssign IntRep ra a
- a2 = StAssign IntRep rs (StPrim IntNegOp [s])
- a3 = StAssign PtrRep rd d
- in
- returnUs (\xs -> a1 : a2 : a3 : xs)
-\end{code}
-
-Support for the Gnu GMP multi-precision package.
-
-\begin{code}
--- size (in words) of __MP_INT
-mpIntSize = 3 :: Int
-
-mpAlloc, mpSize, mpData :: StixTree -> StixTree
-mpAlloc base = StInd IntRep base
-mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
-mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
-\end{code}
-
-\begin{code}
-toStruct
- :: StixTree
- -> (StixTree, StixTree, StixTree)
- -> (StixTree, StixTree, StixTree)
-
-toStruct str (alloc,size,arr)
- = let
- f1 = StAssign IntRep (mpAlloc str) alloc
- f2 = StAssign IntRep (mpSize str) size
- f3 = StAssign PtrRep (mpData str) arr
- in
- (f1, f2, f3)
-
-scratch1 = StScratchWord 0
-scratch2 = StScratchWord mpIntSize
-\end{code}
-
import {-# SOURCE #-} StixPrim ( amodeToStix )
import MachRegs
-import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg,
- CCheckMacro(..) )
+import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) )
import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
import ForeignCall ( CCallConv(..) )
-import PrimOp ( PrimOp(..) )
+import MachOp ( MachOp(..) )
import PrimRep ( PrimRep(..) )
import Stix
+import Panic ( panic )
import UniqSupply ( returnUs, thenUs, UniqSM )
import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel,
macroCode
:: CStmtMacro -- statement macro
-> [CAddrMode] -- args
- -> UniqSM StixTreeList
+ -> UniqSM StixStmtList
\end{code}
-----------------------------------------------------------------------------
= getUniqLabelNCG `thenUs` \ ulbl ->
let
[words, lbl] = map amodeToStix args
- temp = StIndex PtrRep stgSp words
- test = StPrim AddrGeOp [stgSu, temp]
+ temp = StIndex PtrRep (StReg stgSp) words
+ test = StMachOp MO_NatU_Ge [StReg stgSu, temp]
cjmp = StCondJump ulbl test
- assign = StAssign PtrRep stgNode lbl
+ assign = StAssignReg PtrRep stgNode lbl
join = StLabel ulbl
in
returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
macroCode ARGS_CHK [words]
= getUniqLabelNCG `thenUs` \ ulbl ->
- let temp = StIndex PtrRep stgSp (amodeToStix words)
- test = StPrim AddrGeOp [stgSu, temp]
+ let temp = StIndex PtrRep (StReg stgSp) (amodeToStix words)
+ test = StMachOp MO_NatU_Ge [StReg stgSu, temp]
cjmp = StCondJump ulbl test
join = StLabel ulbl
in
macroCode UPD_CAF args
= let
[cafptr,bhptr] = map amodeToStix args
- new_caf = StCall SLIT("newCAF") CCallConv VoidRep [cafptr]
- w0 = StInd PtrRep cafptr
- w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
- a1 = StAssign PtrRep w1 bhptr
- a2 = StAssign PtrRep w0 ind_static_info
+ new_caf = StVoidable (StCall SLIT("newCAF") CCallConv VoidRep [cafptr])
+ a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
+ a2 = StAssignMem PtrRep cafptr ind_static_info
in
returnUs (\xs -> new_caf : a1 : a2 : xs)
\end{code}
macroCode PUSH_UPD_FRAME args
= let
[bhptr, _{-0-}] = map amodeToStix args
- frame n = StInd PtrRep
- (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
+ frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE)))
-- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
- a1 = StAssign PtrRep (frame uF_RET) upd_frame_info
- a3 = StAssign PtrRep (frame uF_SU) stgSu
- a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
-
- updSu = StAssign PtrRep stgSu
- (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
+ a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info
+ a3 = StAssignMem PtrRep (frame uF_SU) (StReg stgSu)
+ a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
+
+ updSu = StAssignReg
+ PtrRep
+ stgSu
+ (StIndex PtrRep (StReg stgSp) (StInt (toInteger (-uF_SIZE))))
in
returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
macroCode PUSH_SEQ_FRAME args
= let [arg_frame] = map amodeToStix args
- frame n = StInd PtrRep
- (StIndex PtrRep arg_frame (StInt (toInteger n)))
- a1 = StAssign PtrRep (frame 0) seq_frame_info
- a2 = StAssign PtrRep (frame 1) stgSu
- updSu = StAssign PtrRep stgSu arg_frame
+ frame n = StIndex PtrRep arg_frame (StInt (toInteger n))
+ a1 = StAssignMem PtrRep (frame 0) seq_frame_info
+ a2 = StAssignMem PtrRep (frame 1) (StReg stgSu)
+ updSu = StAssignReg PtrRep stgSu arg_frame
in
returnUs (\xs -> a1 : a2 : updSu : xs)
macroCode UPDATE_SU_FROM_UPD_FRAME args
= let [arg_frame] = map amodeToStix args
- frame n = StInd PtrRep
- (StIndex PtrRep arg_frame (StInt (toInteger n)))
- updSu
- = StAssign PtrRep stgSu (frame uF_SU)
+ frame n = StIndex PtrRep arg_frame (StInt (toInteger n))
+ updSu = StAssignReg PtrRep stgSu (StInd PtrRep (frame uF_SU))
in
returnUs (\xs -> updSu : xs)
\end{code}
\begin{code}
macroCode SET_TAG [tag]
- = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
- in
- case stgReg tagreg of
- Always _ -> returnUs id
- Save _ -> returnUs (\ xs -> set_tag : xs)
+ = case get_MagicId_reg_or_addr tagreg of
+ Right baseRegAddr
+ -> returnUs id
+ Left realreg
+ -> let a1 = StAssignReg IntRep (StixMagicId tagreg) (amodeToStix tag)
+ in returnUs ( \xs -> a1 : xs )
\end{code}
-----------------------------------------------------------------------------
\begin{code}
macroCode REGISTER_IMPORT [arg]
= returnUs (
- \xs -> StAssign WordRep (StInd WordRep stgSp) (amodeToStix arg)
- : StAssign PtrRep stgSp (StPrim IntAddOp [stgSp, StInt 4])
+ \xs -> StAssignMem WordRep (StReg stgSp) (amodeToStix arg)
+ : StAssignReg PtrRep stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4])
: xs
)
macroCode REGISTER_FOREIGN_EXPORT [arg]
= returnUs (
- \xs -> StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg]
+ \xs -> StVoidable (
+ StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg]
+ )
: xs
)
macroCode other args
- = case other of
- SET_TAG -> error "foobarxyzzy8"
- _ -> error "StixMacro.macroCode: unknown macro/args"
+ = panic "StixMacro.macroCode"
\end{code}
-
Do the business for a @HEAP_CHK@, having converted the args to Trees
of StixOp.
\begin{code}
-- Some common labels
-bh_info, ind_static_info, ind_info :: StixTree
+bh_info, ind_static_info, ind_info :: StixExpr
bh_info = StCLbl mkBlackHoleInfoTableLabel
ind_static_info = StCLbl mkIndStaticInfoLabel
upd_frame_info = StCLbl mkUpdInfoLabel
seq_frame_info = StCLbl mkSeqInfoLabel
-stg_update_PAP = regTableEntry CodePtrRep OFFSET_stgUpdatePAP
-
-- Some common call trees
-updatePAP :: StixTree
-updatePAP = StJump NoDestInfo stg_update_PAP
+updatePAP :: StixStmt
+updatePAP = mkStJump_to_RegTable_offw OFFSET_stgUpdatePAP
+
\end{code}
-----------------------------------------------------------------------------
Heap/Stack checks
\begin{code}
-checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
+checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
checkCode macro args assts
= getUniqLabelNCG `thenUs` \ ulbl_fail ->
getUniqLabelNCG `thenUs` \ ulbl_pass ->
- let args_stix = map amodeToStix args
- newHp wds = StIndex PtrRep stgHp wds
- assign_hp wds = StAssign PtrRep stgHp (newHp wds)
- hp_alloc wds = StAssign IntRep stgHpAlloc wds
- test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
- cjmp_hp = StCondJump ulbl_pass test_hp
-
- newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
- test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
- test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
+ let args_stix = map amodeToStix args
+ newHp wds = StIndex PtrRep (StReg stgHp) wds
+ assign_hp wds = StAssignReg PtrRep stgHp (newHp wds)
+ hp_alloc wds = StAssignReg IntRep stgHpAlloc wds
+ test_hp = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
+ cjmp_hp = StCondJump ulbl_pass test_hp
+ newSp wds = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
+ test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
+ test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
-
- assign_ret r ret = StAssign CodePtrRep r ret
+ assign_ret r ret = mkStAssign CodePtrRep r ret
fail = StLabel ulbl_fail
join = StLabel ulbl_pass
= IF_ARCH_alpha(16383,65535)
assign_liveness ptr_regs
- = StAssign WordRep stgR9
- (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs])
+ = StAssignReg WordRep stgR9
+ (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs])
assign_reentry reentry
- = StAssign WordRep stgR10 reentry
+ = StAssignReg WordRep stgR10 reentry
in
returnUs (
-- Various canned heap-check routines
-mkStJump_to_GCentry :: String -> StixTree
-mkStJump_to_GCentry gcname
+mkStJump_to_GCentry_name :: String -> StixStmt
+mkStJump_to_GCentry_name gcname
-- | opt_Static
= StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
-- | otherwise -- it's in a different DLL
-- = StJump (StInd PtrRep (StLitLbl True sdoc))
-gc_chk (StInt 0) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgChk0)
-gc_chk (StInt 1) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgChk1)
-gc_chk (StInt n) = mkStJump_to_GCentry ("stg_chk_" ++ show n)
-
-gc_enter (StInt 1) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgGCEnter1)
-gc_enter (StInt n) = mkStJump_to_GCentry ("stg_gc_enter_" ++ show n)
-
-gc_seq (StInt n) = mkStJump_to_GCentry ("stg_gc_seq_" ++ show n)
-gc_noregs = mkStJump_to_GCentry "stg_gc_noregs"
-gc_unpt_r1 = mkStJump_to_GCentry "stg_gc_unpt_r1"
-gc_unbx_r1 = mkStJump_to_GCentry "stg_gc_unbx_r1"
-gc_f1 = mkStJump_to_GCentry "stg_gc_f1"
-gc_d1 = mkStJump_to_GCentry "stg_gc_d1"
-gc_gen = mkStJump_to_GCentry "stg_gen_chk"
+mkStJump_to_RegTable_offw :: Int -> StixStmt
+mkStJump_to_RegTable_offw regtable_offw
+-- | opt_Static
+ = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw))
+-- | otherwise
+-- do something plausible for cross-DLL jump
+
+gc_chk (StInt 0) = mkStJump_to_RegTable_offw OFFSET_stgChk0
+gc_chk (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgChk1
+gc_chk (StInt n) = mkStJump_to_GCentry_name ("stg_chk_" ++ show n)
+
+gc_enter (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
+gc_enter (StInt n) = mkStJump_to_GCentry_name ("stg_gc_enter_" ++ show n)
+
+gc_seq (StInt n) = mkStJump_to_GCentry_name ("stg_gc_seq_" ++ show n)
+gc_noregs = mkStJump_to_GCentry_name "stg_gc_noregs"
+gc_unpt_r1 = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
+gc_unbx_r1 = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
+gc_f1 = mkStJump_to_GCentry_name "stg_gc_f1"
+gc_d1 = mkStJump_to_GCentry_name "stg_gc_d1"
+gc_gen = mkStJump_to_GCentry_name "stg_gen_chk"
gc_ut (StInt p) (StInt np)
- = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p
- ++ "_" ++ show np)
+ = mkStJump_to_GCentry_name ("stg_gc_ut_" ++ show p ++ "_" ++ show np)
\end{code}
_exports_
StixPrim amodeToStix;
_declarations_
-1 amodeToStix _:_ AbsCSyn.CAddrMode -> Stix.StixTree ;;
+1 amodeToStix _:_ AbsCSyn.CAddrMode -> Stix.StixExpr ;;
__interface StixPrim 1 0 where
__export StixPrim amodeToStix;
-1 amodeToStix :: AbsCSyn.CAddrMode -> Stix.StixTree ;
+1 amodeToStix :: AbsCSyn.CAddrMode -> Stix.StixExpr ;
%
\begin{code}
-module StixPrim ( primCode, amodeToStix, amodeToStix', foreignCallCode )
- where
+module StixPrim ( amodeToStix, amodeToStix', foreignCallCode )
+where
#include "HsVersions.h"
import MachMisc
import Stix
-import StixInteger
+import PprAbsC ( pprAmode )
import AbsCSyn hiding ( spRel )
import AbsCUtils ( getAmodeRep, mixedTypeLocn )
import SMRep ( fixedHdrSize )
import Literal ( Literal(..), word2IntLit )
-import PrimOp ( PrimOp(..) )
+import MachOp ( MachOp(..) )
import PrimRep ( PrimRep(..), getPrimRepSizeInBytes )
import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
import Constants ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
#include "NCG.h"
\end{code}
-The main honchos here are primCode anf foreignCallCode, which handle the guts of COpStmts.
+The main honchos here are primCode and foreignCallCode, which handle the guts of COpStmts.
\begin{code}
foreignCallCode
:: [CAddrMode] -- results
-> ForeignCall -- op
-> [CAddrMode] -- args
- -> UniqSM StixTreeList
-
-primCode
- :: [CAddrMode] -- results
- -> PrimOp -- op
- -> [CAddrMode] -- args
- -> UniqSM StixTreeList
+ -> UniqSM StixStmtList
\end{code}
%************************************************************************
\begin{code}
foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
- | not (playSafe safety) = returnUs (\xs -> ccall : xs)
+
+ | not (playSafe safety)
+ = returnUs (\xs -> ccall : xs)
| otherwise
= save_thread_state `thenUs` \ save ->
load_thread_state `thenUs` \ load ->
getUniqueUs `thenUs` \ uniq ->
let
- id = StReg (StixTemp uniq IntRep)
+ id = StixTemp (StixVReg uniq IntRep)
- suspend = StAssign IntRep id
- (StCall SLIT("suspendThread") {-no:cconv-} CCallConv
- IntRep [stgBaseReg])
- resume = StCall SLIT("resumeThread") {-no:cconv-} CCallConv
- VoidRep [id]
+ suspend = StAssignReg IntRep id
+ (StCall SLIT("suspendThread") {-no:cconv-} CCallConv
+ IntRep [StReg stgBaseReg])
+ resume = StVoidable
+ (StCall SLIT("resumeThread") {-no:cconv-} CCallConv
+ VoidRep [StReg id])
in
returnUs (\xs -> save (suspend : ccall : resume : load xs))
_ -> base
ccall = case lhs of
- [] -> StCall fn cconv VoidRep args
- [lhs] -> StAssign pk lhs' (StCall fn cconv pk args)
+ [] -> StVoidable (StCall fn cconv VoidRep args)
+ [lhs] -> mkStAssign pk lhs' (StCall fn cconv pk args)
where
lhs' = amodeToStix lhs
pk = case getAmodeRep lhs of
= ncgPrimopMoan "Native code generator can't handle foreign call" (ppr call)
\end{code}
-
%************************************************************************
%* *
-\subsubsection{Code for primops}
+\subsubsection{Code for @CAddrMode@s}
%* *
%************************************************************************
-The (MP) integer operations are a true nightmare. Since we don't have
-a convenient abstract way of allocating temporary variables on the (C)
-stack, we use the space just below HpLim for the @MP_INT@ structures,
-and modify our heap check accordingly.
-
-\begin{code}
--- NB: ordering of clauses somewhere driven by
--- the desire to getting sane patt-matching behavior
-
-primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
- = gmpCompare res (sa1,da1, sa2,da2)
-
-primCode [res] IntegerCmpIntOp args@[sa1,da1,ai]
- = gmpCompareInt res (sa1,da1,ai)
-
-primCode [res] Integer2IntOp arg@[sa,da]
- = gmpInteger2Int res (sa,da)
-
-primCode [res] Integer2WordOp arg@[sa,da]
- = gmpInteger2Word res (sa,da)
-
-primCode [res] Int2WordOp [arg]
- = simpleCoercion IntRep{-WordRep?-} res arg
-
-primCode [res] Word2IntOp [arg]
- = simpleCoercion IntRep res arg
-
-primCode [res] AddrToHValueOp [arg]
- = simpleCoercion PtrRep res arg
-
-#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64)
-primCode [res] Int2AddrOp [arg]
- = simpleCoercion AddrRep res arg
-
-primCode [res] Addr2IntOp [arg]
- = simpleCoercion IntRep res arg
-#endif
-
-primCode [res] Narrow8IntOp [arg]
- = narrowingCoercion IntRep Int8Rep res arg
-primCode [res] Narrow16IntOp [arg]
- = narrowingCoercion IntRep Int16Rep res arg
-primCode [res] Narrow32IntOp [arg]
- = narrowingCoercion IntRep Int32Rep res arg
-
-primCode [res] Narrow8WordOp [arg]
- = narrowingCoercion WordRep Word8Rep res arg
-primCode [res] Narrow16WordOp [arg]
- = narrowingCoercion WordRep Word16Rep res arg
-primCode [res] Narrow32WordOp [arg]
- = narrowingCoercion WordRep Word32Rep res arg
-\end{code}
-
-\begin{code}
-primCode [res] SameMutableArrayOp args
- = let
- compare = StPrim AddrEqOp (map amodeToStix args)
- assign = StAssign IntRep (amodeToStix res) compare
- in
- returnUs (\xs -> assign : xs)
-
-primCode res@[_] SameMutableByteArrayOp args
- = primCode res SameMutableArrayOp args
-
-primCode res@[_] SameMutVarOp args
- = primCode res SameMutableArrayOp args
-\end{code}
-
-\begin{code}
-primCode res@[_] SameMVarOp args
- = primCode res SameMutableArrayOp args
-
--- #define isEmptyMVarzh(r,a) \
--- r =(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info )
-primCode [res] IsEmptyMVarOp [arg]
- = let res' = amodeToStix res
- arg' = amodeToStix arg
- arg_info = StInd PtrRep arg'
- em_info = StCLbl mkEMPTY_MVAR_infoLabel
- same = StPrim IntEqOp [arg_info, em_info]
- assign = StAssign IntRep res' same
- in
- returnUs (\xs -> assign : xs)
-
--- #define myThreadIdzh(t) (t = CurrentTSO)
-primCode [res] MyThreadIdOp []
- = let res' = amodeToStix res
- in returnUs (\xs -> StAssign ThreadIdRep res' stgCurrentTSO : xs)
-
-\end{code}
-
-Freezing an array of pointers is a double assignment. We fix the
-header of the ``new'' closure because the lhs is probably a better
-addressing mode for the indirection (most likely, it's a VanillaReg).
-
-\begin{code}
-
-primCode [lhs] UnsafeFreezeArrayOp [rhs]
- = let
- lhs' = amodeToStix lhs
- rhs' = amodeToStix rhs
- header = StInd PtrRep lhs'
- assign = StAssign PtrRep lhs' rhs'
- freeze = StAssign PtrRep header mutArrPtrsFrozen_info
- in
- returnUs (\xs -> assign : freeze : xs)
-
-primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
- = simpleCoercion PtrRep lhs rhs
-\end{code}
-
-Returning the size of (mutable) byte arrays is just
-an indexing operation.
-
-\begin{code}
-primCode [lhs] SizeofByteArrayOp [rhs]
- = let
- lhs' = amodeToStix lhs
- rhs' = amodeToStix rhs
- sz = StIndex IntRep rhs' fixedHS
- assign = StAssign IntRep lhs' (StInd IntRep sz)
- in
- returnUs (\xs -> assign : xs)
-
-primCode [lhs] SizeofMutableByteArrayOp [rhs]
- = let
- lhs' = amodeToStix lhs
- rhs' = amodeToStix rhs
- sz = StIndex IntRep rhs' fixedHS
- assign = StAssign IntRep lhs' (StInd IntRep sz)
- in
- returnUs (\xs -> assign : xs)
-
-\end{code}
-
-Most other array primitives translate to simple indexing.
-
-\begin{code}
-primCode lhs@[_] IndexArrayOp args
- = primCode lhs ReadArrayOp args
-
-primCode [lhs] ReadArrayOp [obj, ix]
- = let
- lhs' = amodeToStix lhs
- obj' = amodeToStix obj
- ix' = amodeToStix ix
- base = StIndex IntRep obj' arrPtrsHS
- assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
- in
- returnUs (\xs -> assign : xs)
-
-primCode [] WriteArrayOp [obj, ix, v]
- = let
- obj' = amodeToStix obj
- ix' = amodeToStix ix
- v' = amodeToStix v
- base = StIndex IntRep obj' arrPtrsHS
- assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
- in
- returnUs (\xs -> assign : xs)
-
-primCode [] WriteForeignObjOp [obj, v]
- = let
- obj' = amodeToStix obj
- v' = amodeToStix v
- obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
- assign = StAssign AddrRep (StInd AddrRep obj'') v'
- in
- returnUs (\xs -> assign : xs)
-
--- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
-primCode ls IndexByteArrayOp_Char rs = primCode_ReadByteArrayOp Word8Rep ls rs
-primCode ls IndexByteArrayOp_WideChar rs = primCode_ReadByteArrayOp CharRep ls rs
-primCode ls IndexByteArrayOp_Int rs = primCode_ReadByteArrayOp IntRep ls rs
-primCode ls IndexByteArrayOp_Word rs = primCode_ReadByteArrayOp WordRep ls rs
-primCode ls IndexByteArrayOp_Addr rs = primCode_ReadByteArrayOp AddrRep ls rs
-primCode ls IndexByteArrayOp_Float rs = primCode_ReadByteArrayOp FloatRep ls rs
-primCode ls IndexByteArrayOp_Double rs = primCode_ReadByteArrayOp DoubleRep ls rs
-primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
-primCode ls IndexByteArrayOp_Int8 rs = primCode_ReadByteArrayOp Int8Rep ls rs
-primCode ls IndexByteArrayOp_Int16 rs = primCode_ReadByteArrayOp Int16Rep ls rs
-primCode ls IndexByteArrayOp_Int32 rs = primCode_ReadByteArrayOp Int32Rep ls rs
-primCode ls IndexByteArrayOp_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs
-primCode ls IndexByteArrayOp_Word8 rs = primCode_ReadByteArrayOp Word8Rep ls rs
-primCode ls IndexByteArrayOp_Word16 rs = primCode_ReadByteArrayOp Word16Rep ls rs
-primCode ls IndexByteArrayOp_Word32 rs = primCode_ReadByteArrayOp Word32Rep ls rs
-primCode ls IndexByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs
-
-primCode ls ReadByteArrayOp_Char rs = primCode_ReadByteArrayOp Word8Rep ls rs
-primCode ls ReadByteArrayOp_WideChar rs = primCode_ReadByteArrayOp CharRep ls rs
-primCode ls ReadByteArrayOp_Int rs = primCode_ReadByteArrayOp IntRep ls rs
-primCode ls ReadByteArrayOp_Word rs = primCode_ReadByteArrayOp WordRep ls rs
-primCode ls ReadByteArrayOp_Addr rs = primCode_ReadByteArrayOp AddrRep ls rs
-primCode ls ReadByteArrayOp_Float rs = primCode_ReadByteArrayOp FloatRep ls rs
-primCode ls ReadByteArrayOp_Double rs = primCode_ReadByteArrayOp DoubleRep ls rs
-primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
-primCode ls ReadByteArrayOp_Int8 rs = primCode_ReadByteArrayOp Int8Rep ls rs
-primCode ls ReadByteArrayOp_Int16 rs = primCode_ReadByteArrayOp Int16Rep ls rs
-primCode ls ReadByteArrayOp_Int32 rs = primCode_ReadByteArrayOp Int32Rep ls rs
-primCode ls ReadByteArrayOp_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs
-primCode ls ReadByteArrayOp_Word8 rs = primCode_ReadByteArrayOp Word8Rep ls rs
-primCode ls ReadByteArrayOp_Word16 rs = primCode_ReadByteArrayOp Word16Rep ls rs
-primCode ls ReadByteArrayOp_Word32 rs = primCode_ReadByteArrayOp Word32Rep ls rs
-primCode ls ReadByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs
-
-primCode ls WriteByteArrayOp_Char rs = primCode_WriteByteArrayOp Word8Rep ls rs
-primCode ls WriteByteArrayOp_WideChar rs = primCode_WriteByteArrayOp CharRep ls rs
-primCode ls WriteByteArrayOp_Int rs = primCode_WriteByteArrayOp IntRep ls rs
-primCode ls WriteByteArrayOp_Word rs = primCode_WriteByteArrayOp WordRep ls rs
-primCode ls WriteByteArrayOp_Addr rs = primCode_WriteByteArrayOp AddrRep ls rs
-primCode ls WriteByteArrayOp_Float rs = primCode_WriteByteArrayOp FloatRep ls rs
-primCode ls WriteByteArrayOp_Double rs = primCode_WriteByteArrayOp DoubleRep ls rs
-primCode ls WriteByteArrayOp_StablePtr rs = primCode_WriteByteArrayOp StablePtrRep ls rs
-primCode ls WriteByteArrayOp_Int8 rs = primCode_WriteByteArrayOp Int8Rep ls rs
-primCode ls WriteByteArrayOp_Int16 rs = primCode_WriteByteArrayOp Int16Rep ls rs
-primCode ls WriteByteArrayOp_Int32 rs = primCode_WriteByteArrayOp Int32Rep ls rs
-primCode ls WriteByteArrayOp_Int64 rs = primCode_WriteByteArrayOp Int64Rep ls rs
-primCode ls WriteByteArrayOp_Word8 rs = primCode_WriteByteArrayOp Word8Rep ls rs
-primCode ls WriteByteArrayOp_Word16 rs = primCode_WriteByteArrayOp Word16Rep ls rs
-primCode ls WriteByteArrayOp_Word32 rs = primCode_WriteByteArrayOp Word32Rep ls rs
-primCode ls WriteByteArrayOp_Word64 rs = primCode_WriteByteArrayOp Word64Rep ls rs
-
-primCode ls IndexOffAddrOp_Char rs = primCode_IndexOffAddrOp Word8Rep ls rs
-primCode ls IndexOffAddrOp_WideChar rs = primCode_IndexOffAddrOp CharRep ls rs
-primCode ls IndexOffAddrOp_Int rs = primCode_IndexOffAddrOp IntRep ls rs
-primCode ls IndexOffAddrOp_Word rs = primCode_IndexOffAddrOp WordRep ls rs
-primCode ls IndexOffAddrOp_Addr rs = primCode_IndexOffAddrOp AddrRep ls rs
-primCode ls IndexOffAddrOp_Float rs = primCode_IndexOffAddrOp FloatRep ls rs
-primCode ls IndexOffAddrOp_Double rs = primCode_IndexOffAddrOp DoubleRep ls rs
-primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
-primCode ls IndexOffAddrOp_Int8 rs = primCode_IndexOffAddrOp Int8Rep ls rs
-primCode ls IndexOffAddrOp_Int16 rs = primCode_IndexOffAddrOp Int16Rep ls rs
-primCode ls IndexOffAddrOp_Int32 rs = primCode_IndexOffAddrOp Int32Rep ls rs
-primCode ls IndexOffAddrOp_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs
-primCode ls IndexOffAddrOp_Word8 rs = primCode_IndexOffAddrOp Word8Rep ls rs
-primCode ls IndexOffAddrOp_Word16 rs = primCode_IndexOffAddrOp Word16Rep ls rs
-primCode ls IndexOffAddrOp_Word32 rs = primCode_IndexOffAddrOp Word32Rep ls rs
-primCode ls IndexOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs
-
-primCode ls IndexOffForeignObjOp_Char rs = primCode_IndexOffForeignObjOp Word8Rep ls rs
-primCode ls IndexOffForeignObjOp_WideChar rs = primCode_IndexOffForeignObjOp CharRep ls rs
-primCode ls IndexOffForeignObjOp_Int rs = primCode_IndexOffForeignObjOp IntRep ls rs
-primCode ls IndexOffForeignObjOp_Word rs = primCode_IndexOffForeignObjOp WordRep ls rs
-primCode ls IndexOffForeignObjOp_Addr rs = primCode_IndexOffForeignObjOp AddrRep ls rs
-primCode ls IndexOffForeignObjOp_Float rs = primCode_IndexOffForeignObjOp FloatRep ls rs
-primCode ls IndexOffForeignObjOp_Double rs = primCode_IndexOffForeignObjOp DoubleRep ls rs
-primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp StablePtrRep ls rs
-primCode ls IndexOffForeignObjOp_Int8 rs = primCode_IndexOffForeignObjOp Int8Rep ls rs
-primCode ls IndexOffForeignObjOp_Int16 rs = primCode_IndexOffForeignObjOp Int16Rep ls rs
-primCode ls IndexOffForeignObjOp_Int32 rs = primCode_IndexOffForeignObjOp Int32Rep ls rs
-primCode ls IndexOffForeignObjOp_Int64 rs = primCode_IndexOffForeignObjOp Int64Rep ls rs
-primCode ls IndexOffForeignObjOp_Word8 rs = primCode_IndexOffForeignObjOp Word8Rep ls rs
-primCode ls IndexOffForeignObjOp_Word16 rs = primCode_IndexOffForeignObjOp Word16Rep ls rs
-primCode ls IndexOffForeignObjOp_Word32 rs = primCode_IndexOffForeignObjOp Word32Rep ls rs
-primCode ls IndexOffForeignObjOp_Word64 rs = primCode_IndexOffForeignObjOp Word64Rep ls rs
-
-primCode ls ReadOffAddrOp_Char rs = primCode_IndexOffAddrOp Word8Rep ls rs
-primCode ls ReadOffAddrOp_WideChar rs = primCode_IndexOffAddrOp CharRep ls rs
-primCode ls ReadOffAddrOp_Int rs = primCode_IndexOffAddrOp IntRep ls rs
-primCode ls ReadOffAddrOp_Word rs = primCode_IndexOffAddrOp WordRep ls rs
-primCode ls ReadOffAddrOp_Addr rs = primCode_IndexOffAddrOp AddrRep ls rs
-primCode ls ReadOffAddrOp_Float rs = primCode_IndexOffAddrOp FloatRep ls rs
-primCode ls ReadOffAddrOp_Double rs = primCode_IndexOffAddrOp DoubleRep ls rs
-primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
-primCode ls ReadOffAddrOp_Int8 rs = primCode_IndexOffAddrOp Int8Rep ls rs
-primCode ls ReadOffAddrOp_Int16 rs = primCode_IndexOffAddrOp Int16Rep ls rs
-primCode ls ReadOffAddrOp_Int32 rs = primCode_IndexOffAddrOp Int32Rep ls rs
-primCode ls ReadOffAddrOp_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs
-primCode ls ReadOffAddrOp_Word8 rs = primCode_IndexOffAddrOp Word8Rep ls rs
-primCode ls ReadOffAddrOp_Word16 rs = primCode_IndexOffAddrOp Word16Rep ls rs
-primCode ls ReadOffAddrOp_Word32 rs = primCode_IndexOffAddrOp Word32Rep ls rs
-primCode ls ReadOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs
-
-primCode ls WriteOffAddrOp_Char rs = primCode_WriteOffAddrOp Word8Rep ls rs
-primCode ls WriteOffAddrOp_WideChar rs = primCode_WriteOffAddrOp CharRep ls rs
-primCode ls WriteOffAddrOp_Int rs = primCode_WriteOffAddrOp IntRep ls rs
-primCode ls WriteOffAddrOp_Word rs = primCode_WriteOffAddrOp WordRep ls rs
-primCode ls WriteOffAddrOp_Addr rs = primCode_WriteOffAddrOp AddrRep ls rs
-primCode ls WriteOffAddrOp_Float rs = primCode_WriteOffAddrOp FloatRep ls rs
-primCode ls WriteOffAddrOp_Double rs = primCode_WriteOffAddrOp DoubleRep ls rs
-primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep ls rs
-primCode ls WriteOffAddrOp_Int8 rs = primCode_WriteOffAddrOp Int8Rep ls rs
-primCode ls WriteOffAddrOp_Int16 rs = primCode_WriteOffAddrOp Int16Rep ls rs
-primCode ls WriteOffAddrOp_Int32 rs = primCode_WriteOffAddrOp Int32Rep ls rs
-primCode ls WriteOffAddrOp_Int64 rs = primCode_WriteOffAddrOp Int64Rep ls rs
-primCode ls WriteOffAddrOp_Word8 rs = primCode_WriteOffAddrOp Word8Rep ls rs
-primCode ls WriteOffAddrOp_Word16 rs = primCode_WriteOffAddrOp Word16Rep ls rs
-primCode ls WriteOffAddrOp_Word32 rs = primCode_WriteOffAddrOp Word32Rep ls rs
-primCode ls WriteOffAddrOp_Word64 rs = primCode_WriteOffAddrOp Word64Rep ls rs
-
-\end{code}
-
-
-DataToTagOp won't work for 64-bit archs, as it is.
-
-\begin{code}
-primCode [lhs] DataToTagOp [arg]
- = let lhs' = amodeToStix lhs
- arg' = amodeToStix arg
- infoptr = StInd PtrRep arg'
- word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
- masked_le32 = StPrim SrlOp [word_32, StInt 16]
- masked_be32 = StPrim AndOp [word_32, StInt 65535]
-#ifdef WORDS_BIGENDIAN
- masked = masked_be32
-#else
- masked = masked_le32
-#endif
- assign = StAssign IntRep lhs' masked
- in
- returnUs (\xs -> assign : xs)
-\end{code}
-
-MutVars are pretty simple.
-#define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
-
-\begin{code}
-primCode [] WriteMutVarOp [aa,vv]
- = let aa_s = amodeToStix aa
- vv_s = amodeToStix vv
- var_field = StIndex PtrRep aa_s fixedHS
- assign = StAssign PtrRep (StInd PtrRep var_field) vv_s
- in
- returnUs (\xs -> assign : xs)
-
-primCode [rr] ReadMutVarOp [aa]
- = let aa_s = amodeToStix aa
- rr_s = amodeToStix rr
- var_field = StIndex PtrRep aa_s fixedHS
- assign = StAssign PtrRep rr_s (StInd PtrRep var_field)
- in
- returnUs (\xs -> assign : xs)
-\end{code}
-
-ForeignObj# primops.
-
-\begin{code}
-primCode [rr] ForeignObjToAddrOp [fo]
- = let code = StAssign AddrRep (amodeToStix rr)
- (StInd AddrRep
- (StIndex PtrRep (amodeToStix fo) fixedHS))
- in
- returnUs (\xs -> code : xs)
-
-primCode [] TouchOp [_] = returnUs id
-\end{code}
-
-Now the more mundane operations.
-
-\begin{code}
-primCode lhs op rhs
- = let
- lhs' = map amodeToStix lhs
- rhs' = map amodeToStix' rhs
- pk = getAmodeRep (head lhs)
- in
- returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
-\end{code}
-
-Helper fns for some array ops.
-
-\begin{code}
-primCode_ReadByteArrayOp pk [lhs] [obj, ix]
- = let
- lhs' = amodeToStix lhs
- obj' = amodeToStix obj
- ix' = amodeToStix ix
- base = StIndex IntRep obj' arrWordsHS
- assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
- in
- returnUs (\xs -> assign : xs)
-
-
-primCode_IndexOffAddrOp pk [lhs] [obj, ix]
- = let
- lhs' = amodeToStix lhs
- obj' = amodeToStix obj
- ix' = amodeToStix ix
- assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
- in
- returnUs (\xs -> assign : xs)
-
-
-primCode_IndexOffForeignObjOp pk [lhs] [obj, ix]
- = let
- lhs' = amodeToStix lhs
- obj' = amodeToStix obj
- ix' = amodeToStix ix
- obj'' = StIndex AddrRep obj' fixedHS
- assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
- in
- returnUs (\xs -> assign : xs)
-
-
-primCode_WriteOffAddrOp pk [] [obj, ix, v]
- = let
- obj' = amodeToStix obj
- ix' = amodeToStix ix
- v' = amodeToStix v
- assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
- in
- returnUs (\xs -> assign : xs)
-
-
-primCode_WriteByteArrayOp pk [] [obj, ix, v]
- = let
- obj' = amodeToStix obj
- ix' = amodeToStix ix
- v' = amodeToStix v
- base = StIndex IntRep obj' arrWordsHS
- assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
- in
- returnUs (\xs -> assign : xs)
-
-\end{code}
-
-\begin{code}
-simpleCoercion
- :: PrimRep
- -> CAddrMode
- -> CAddrMode
- -> UniqSM StixTreeList
-
-simpleCoercion pk lhs rhs
- = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
-
-
--- Rewrite a narrowing coercion into a pair of shifts.
-narrowingCoercion
- :: PrimRep -> PrimRep
- -> CAddrMode -> CAddrMode
- -> UniqSM StixTreeList
-
-narrowingCoercion pks pkd dst src
- | szd > szs
- = panic "StixPrim.narrowingCoercion"
- | szd == szs
- = returnUs (\xs -> StAssign pkd dst' src' : xs)
- | otherwise
- = returnUs (\xs -> assign : xs)
- where
- szs = getPrimRepSizeInBytes pks
- szd = getPrimRepSizeInBytes pkd
- src' = amodeToStix src
- dst' = amodeToStix dst
- shift_amt = fromIntegral (8 * (szs - szd))
-
- assign
- = StAssign pkd dst'
- (StPrim (if signed then ISraOp else SrlOp)
- [StPrim SllOp [src', StInt shift_amt],
- StInt shift_amt])
- signed
- = case pkd of
- Int8Rep -> True; Int16Rep -> True
- Int32Rep -> True; Int64Rep -> True; IntRep -> True
- Word8Rep -> False; Word16Rep -> False
- Word32Rep -> False; Word64Rep -> False; WordRep -> False
- other -> pprPanic "StixPrim.narrowingCoercion" (ppr pkd)
-\end{code}
-
-Here we try to rewrite primitives into a form the code generator can
-understand. Any primitives not handled here must be handled at the
-level of the specific code generator.
-
-\begin{code}
-simplePrim
- :: PrimRep -- Rep of first destination
- -> [StixTree] -- Destinations
- -> PrimOp
- -> [StixTree]
- -> StixTree
-\end{code}
-
-Now look for something more conventional.
-
-\begin{code}
-simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
-simplePrim pk as op bs = ncgPrimopMoan "simplPrim(all targets)" (ppr op)
-\end{code}
-
-%---------------------------------------------------------------------
-
-Here we generate the Stix code for CAddrModes.
-
When a character is fetched from a mixed type location, we have to do
an extra cast. This is reflected in amodeCode', which is for rhs
amodes that might possibly need the extra cast.
\begin{code}
-amodeToStix, amodeToStix' :: CAddrMode -> StixTree
+amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
amodeToStix'{-'-} am@(CVal rr CharRep)
- | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
- | otherwise = amodeToStix am
-
-amodeToStix' am = amodeToStix am
+ | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
+ | otherwise = amodeToStix am
+amodeToStix' am
+ = amodeToStix am
-----------
amodeToStix am@(CVal rr CharRep)
amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
+amodeToStix (CMem pk addr) = StInd pk (amodeToStix addr)
+
amodeToStix (CAddr (SpRel off))
- = StIndex PtrRep stgSp (StInt (toInteger (iBox off)))
+ = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
amodeToStix (CAddr (HpRel off))
- = StIndex IntRep stgHp (StInt (toInteger (- (iBox off))))
+ = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
amodeToStix (CAddr (NodeRel off))
- = StIndex IntRep stgNode (StInt (toInteger (iBox off)))
+ = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
amodeToStix (CAddr (CIndex base off pk))
= StIndex pk (amodeToStix base) (amodeToStix off)
amodeToStix (CReg magic) = StReg (StixMagicId magic)
-amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
+amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
amodeToStix (CLbl lbl _) = StCLbl lbl
off = charLikeSize * (c - mIN_CHARLIKE)
amodeToStix (CCharLike x)
- = panic "CCharLike"
+ = panic "amodeToStix.CCharLike"
amodeToStix (CIntLike (CLit (MachInt i)))
= StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
amodeToStix (CIntLike x)
- = panic "CIntLike"
+ = panic "amodeToStix.CIntLike"
amodeToStix (CLit core)
= case core of
ARG_TAG -> amodeToStix arg -- just an integer no. of words
GET_TAG ->
#ifdef WORDS_BIGENDIAN
- StPrim AndOp
+ StMachOp MO_Nat_And
[StInd WordRep (StIndex PtrRep (amodeToStix arg)
(StInt (toInteger (-1)))),
StInt 65535]
#else
- StPrim SrlOp
+ StMachOp MO_Nat_Shr
[StInd WordRep (StIndex PtrRep (amodeToStix arg)
(StInt (toInteger (-1)))),
StInt 16]
-> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
(StInt (toInteger uF_UPDATEE)))
-litLitErr =
- panic "native code generator can't compile lit-lits, use -fvia-C"
+amodeToStix other
+ = pprPanic "StixPrim.amodeToStix" (pprAmode other)
+
+litLitErr
+ = ncgPrimopMoan "native code generator can't handle lit-lits" empty
\end{code}
Sizes of the CharLike and IntLike closures that are arranged as arrays
\begin{code}
-- The INTLIKE base pointer
-iNTLIKE_closure :: StixTree
+iNTLIKE_closure :: StixExpr
iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
-- The CHARLIKE base
-cHARLIKE_closure :: StixTree
+cHARLIKE_closure :: StixExpr
cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
\begin{code}
save_thread_state
- = getUniqueUs `thenUs` \tso_uq ->
- let tso = StReg (StixTemp tso_uq ThreadIdRep) in
+ = getUniqueUs `thenUs` \ tso_uq ->
+ let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
returnUs (\xs ->
- StAssign ThreadIdRep tso stgCurrentTSO :
- StAssign PtrRep
- (StInd PtrRep (StPrim IntAddOp
- [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
- stgSp :
- StAssign PtrRep
- (StInd PtrRep (StPrim IntAddOp
- [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
- stgSu :
- StAssign PtrRep
- (StInd PtrRep (StPrim IntAddOp
- [stgCurrentNursery,
- StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
- (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
- xs
+ StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
+ : StAssignMem PtrRep
+ (StMachOp MO_Nat_Add
+ [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
+ (StReg stgSp)
+ : StAssignMem PtrRep
+ (StMachOp MO_Nat_Add
+ [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])
+ (StReg stgSu)
+ : StAssignMem PtrRep
+ (StMachOp MO_Nat_Add
+ [StReg stgCurrentNursery,
+ StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
+ (StMachOp MO_Nat_Add
+ [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
+ : xs
)
load_thread_state
- = getUniqueUs `thenUs` \tso_uq ->
- let tso = StReg (StixTemp tso_uq ThreadIdRep) in
+ = getUniqueUs `thenUs` \ tso_uq ->
+ let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
returnUs (\xs ->
- StAssign ThreadIdRep tso stgCurrentTSO :
- StAssign PtrRep stgSp
- (StInd PtrRep (StPrim IntAddOp
- [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
- StAssign PtrRep stgSu
- (StInd PtrRep (StPrim IntAddOp
- [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
- StAssign PtrRep stgSpLim
- (StPrim IntAddOp [tso,
- StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
- *BYTES_PER_WORD))]) :
- StAssign PtrRep stgHp
- (StPrim IntSubOp [
- StInd PtrRep (StPrim IntAddOp
- [stgCurrentNursery,
- StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
- StInt (toInteger (1 * BYTES_PER_WORD))
- ]) :
- StAssign PtrRep stgHpLim
- (StPrim IntAddOp [
- StInd PtrRep (StPrim IntAddOp
- [stgCurrentNursery,
- StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
- StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))
- ]) :
- xs
+ StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
+ : StAssignReg PtrRep
+ stgSp
+ (StInd PtrRep
+ (StMachOp MO_Nat_Add
+ [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
+ : StAssignReg PtrRep
+ stgSu
+ (StInd PtrRep
+ (StMachOp MO_Nat_Add
+ [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
+ : StAssignReg PtrRep
+ stgSpLim
+ (StMachOp MO_Nat_Add
+ [StReg tso,
+ StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
+ *BYTES_PER_WORD))])
+ : StAssignReg PtrRep
+ stgHp
+ (StMachOp MO_Nat_Sub
+ [StInd PtrRep
+ (StMachOp MO_Nat_Add
+ [StReg stgCurrentNursery,
+ StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
+ StInt (toInteger (1 * BYTES_PER_WORD))
+ ])
+ : StAssignReg PtrRep
+ stgHpLim
+ (StMachOp MO_Nat_Add
+ [StInd PtrRep
+ (StMachOp MO_Nat_Add
+ [StReg stgCurrentNursery,
+ StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
+ StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))
+ ])
+ : xs
)
\end{code}
stable name.
-[Alastair Reid is to blame for this!]
-
-These days, (Glasgow) Haskell seems to have a bit of everything from
-other languages: strict operations, mutable variables, sequencing,
-pointers, etc. About the only thing left is LISP's ability to test
-for pointer equality. So, let's add it in!
-
-\begin{verbatim}
-reallyUnsafePtrEquality :: a -> a -> Int#
-\end{verbatim}
-
-which tests any two closures (of the same type) to see if they're the
-same. (Returns $0$ for @False@, $\neq 0$ for @True@ - to avoid
-difficulties of trying to box up the result.)
-
-NB This is {\em really unsafe\/} because even something as trivial as
-a garbage collection might change the answer by removing indirections.
-Still, no-one's forcing you to use it. If you're worried about little
-things like loss of referential transparency, you might like to wrap
-it all up in a monad-like thing as John O'Donnell and John Hughes did
-for non-determinism (1989 (Fraserburgh) Glasgow FP Workshop
-Proceedings?)
-
-I'm thinking of using it to speed up a critical equality test in some
-graphics stuff in a context where the possibility of saying that
-denotationally equal things aren't isn't a problem (as long as it
-doesn't happen too often.) ADR
-
-To Will: Jim said this was already in, but I can't see it so I'm
-adding it. Up to you whether you add it. (Note that this could have
-been readily implemented using a @veryDangerousCCall@ before they were
-removed...)
-
-
-- HWL: The first 4 Int# in all par... annotations denote:
-- name, granularity info, size of result, degree of parallelism
-- Same structure as _seq_ i.e. returns Int#
, is64BitRep
, getPrimRepSize
, getPrimRepSizeInBytes
+ , getPrimRepArrayElemSize
, retPrimRepSize
) where
getPrimRepSizeInBytes StableNameRep = wORD_SIZE
getPrimRepSizeInBytes ArrayRep = wORD_SIZE
getPrimRepSizeInBytes ByteArrayRep = wORD_SIZE
-getPrimRepSizeInBytes _ = panic "getPrimRepSize: ouch - this wasn't supposed to happen!"
+getPrimRepSizeInBytes other = pprPanic "getPrimRepSizeInBytes" (ppr other)
+
+
+-- Sizes in bytes of things when they are array elements,
+-- so that we can generate the correct indexing code
+-- inside the compiler. This is not the same as the above
+-- getPrimRepSizeInBytes, the rationale behind which is
+-- unclear to me.
+getPrimRepArrayElemSize :: PrimRep -> Int
+getPrimRepArrayElemSize PtrRep = wORD_SIZE
+getPrimRepArrayElemSize IntRep = wORD_SIZE
+getPrimRepArrayElemSize WordRep = wORD_SIZE
+getPrimRepArrayElemSize AddrRep = wORD_SIZE
+getPrimRepArrayElemSize StablePtrRep = wORD_SIZE
+getPrimRepArrayElemSize ForeignObjRep = wORD_SIZE
+getPrimRepArrayElemSize Word8Rep = 1
+getPrimRepArrayElemSize Word16Rep = 2
+getPrimRepArrayElemSize Word32Rep = 4
+getPrimRepArrayElemSize Word64Rep = 8
+getPrimRepArrayElemSize Int8Rep = 1
+getPrimRepArrayElemSize Int16Rep = 2
+getPrimRepArrayElemSize Int32Rep = 4
+getPrimRepArrayElemSize Int64Rep = 8
+getPrimRepArrayElemSize FloatRep = 4
+getPrimRepArrayElemSize DoubleRep = 8
+getPrimRepArrayElemSize other = pprPanic "getPrimRepSizeArrayElemSize" (ppr other)
\end{code}
-----------------------------------------------------------------------
--- $Id: primops.txt.pp,v 1.9 2001/10/31 17:03:12 rrt Exp $
+-- $Id: primops.txt.pp,v 1.10 2001/12/05 17:35:14 sewardj Exp $
--
-- Primitive Operations
--
with can_fail = True
primop IntGcdOp "gcdInt#" Dyadic Int# -> Int# -> Int#
+ with out_of_line = True
+
primop IntNegOp "negateInt#" Monadic Int# -> Int#
primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
{Add with carry. First member of result is (wrapped) sum; second member is 0 iff no overflow occured.}
primop IntegerIntGcdOp "gcdIntegerInt#" GenPrimOp
Int# -> ByteArr# -> Int# -> Int#
{Greatest common divisor, where second argument is an ordinary Int\#.}
- -- with commutable = True (surely not? APT 8/01)
+ with out_of_line = True
primop IntegerDivExactOp "divExactInteger#" GenPrimOp
Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #)
Int# -> ByteArr# -> Int# -> ByteArr# -> Int#
{Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument.}
with needs_wrapper = True
+ out_of_line = True
primop IntegerCmpIntOp "cmpIntegerInt#" GenPrimOp
Int# -> ByteArr# -> Int# -> Int#
{Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument, which
is an ordinary Int\#.}
with needs_wrapper = True
+ out_of_line = True
primop IntegerQuotRemOp "quotRemInteger#" GenPrimOp
Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #)
primop Integer2IntOp "integer2Int#" GenPrimOp
Int# -> ByteArr# -> Int#
with needs_wrapper = True
+ out_of_line = True
primop Integer2WordOp "integer2Word#" GenPrimOp
Int# -> ByteArr# -> Word#
with needs_wrapper = True
+ out_of_line = True
#if WORD_SIZE_IN_BITS < 32
primop IntegerToInt32Op "integerToInt32#" GenPrimOp
Int# -> ByteArr# -> Word32#
#endif
-#if WORD_SIZE_IN_BITS < 64
-primop IntegerToInt64Op "integerToInt64#" GenPrimOp
- Int# -> ByteArr# -> Int64#
-
-primop IntegerToWord64Op "integerToWord64#" GenPrimOp
- Int# -> ByteArr# -> Word64#
-#endif
-
primop IntegerAndOp "andInteger#" GenPrimOp
Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #)
with out_of_line = True
Int# -> ByteArr# -> (# Int#, ByteArr# #)
with out_of_line = True
-#endif /* ILX */
+#endif /* ndef ILX */
------------------------------------------------------------------------
section "Double#"
{Return 1 if mvar is empty; 0 otherwise.}
with
usage = { mangle IsEmptyMVarOp [mkP, mkP] mkM }
-
+ out_of_line = True
------------------------------------------------------------------------
section "Delay/wait operations"
out_of_line = True
primop MyThreadIdOp "myThreadId#" GenPrimOp
- State# RealWorld -> (# State# RealWorld, ThreadId# #)
+ State# RealWorld -> (# State# RealWorld, ThreadId# #)
+ with
+ out_of_line = True
------------------------------------------------------------------------
section "Weak pointers"
with
usage = { mangle DeRefWeakOp [mkM, mkP] mkM }
has_side_effects = True
+ out_of_line = True
primop FinalizeWeakOp "finalizeWeak#" GenPrimOp
Weak# a -> State# RealWorld -> (# State# RealWorld, Int#,
strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False }
usage = { mangle MakeStablePtrOp [mkM, mkP] mkM }
has_side_effects = True
+ out_of_line = True
primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp
StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)
usage = { mangle DeRefStablePtrOp [mkM, mkP] mkM }
needs_wrapper = True
has_side_effects = True
+ out_of_line = True
primop EqStablePtrOp "eqStablePtr#" GenPrimOp
StablePtr# a -> StablePtr# a -> Int#
usage = { mangle StableNameToIntOp [mkP] mkR }
------------------------------------------------------------------------
-section "Unsafe pointer equality"
--- (#1 Bad Guy: Alistair Reid :)
-------------------------------------------------------------------------
-
-primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
- a -> a -> Int#
- with
- usage = { mangle ReallyUnsafePtrEqualityOp [mkZ, mkZ] mkR }
-
-------------------------------------------------------------------------
section "Parallelism"
------------------------------------------------------------------------
\begin{code}
module Maybes (
- Maybe2(..), Maybe3(..),
+ Maybe012(..), maybe012ToList,
MaybeErr(..),
orElse,
%************************************************************************
%* *
-\subsection[Maybe2,3 types]{The @Maybe2@ and @Maybe3@ types}
+\subsection[Maybe012 type]{The @Maybe012@ type}
%* *
%************************************************************************
\begin{code}
-data Maybe2 a b = Just2 a b | Nothing2 deriving (Eq,Show)
-data Maybe3 a b c = Just3 a b c | Nothing3 deriving (Eq,Show)
+data Maybe012 a = Just0 | Just1 a | Just2 a a deriving (Eq,Show)
+
+maybe012ToList Just0 = []
+maybe012ToList (Just1 x) = [x]
+maybe012ToList (Just2 x y) = [x, y]
\end{code}
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.85 2001/11/21 20:27:18 sof Exp $
+ * $Id: PrimOps.h,v 1.86 2001/12/05 17:35:14 sewardj Exp $
*
* (c) The GHC Team, 1998-2000
*
*
* ---------------------------------------------------------------------------*/
+/* As of 5 Dec 01, this file no longer implements the primops, since they are
+ translated into standard C in compiler/absCSyn/AbsCUtils during the absC
+ flattening pass. Only {add,sub,mul}IntCzh remain untranslated. Most of
+ what is here is now EXTFUN_RTS declarations for the out-of-line primop
+ implementations which live in compiler/rts/PrimOps.hc.
+*/
+
#ifndef PRIMOPS_H
#define PRIMOPS_H
#error GHC C backend requires 32+-bit words
#endif
-/* -----------------------------------------------------------------------------
- Helpers for the bytecode linker.
- -------------------------------------------------------------------------- */
-
-#define addrToHValuezh(r,a) r=(P_)a
-
-
-/* -----------------------------------------------------------------------------
- Comparison PrimOps.
- -------------------------------------------------------------------------- */
-
-#define gtCharzh(r,a,b) r=((C_)(a))> ((C_)(b))
-#define geCharzh(r,a,b) r=((C_)(a))>=((C_)(b))
-#define eqCharzh(r,a,b) r=((C_)(a))==((C_)(b))
-#define neCharzh(r,a,b) r=((C_)(a))!=((C_)(b))
-#define ltCharzh(r,a,b) r=((C_)(a))< ((C_)(b))
-#define leCharzh(r,a,b) r=((C_)(a))<=((C_)(b))
-
-/* Int comparisons: >#, >=# etc */
-#define zgzh(r,a,b) r=((I_)(a))> ((I_)(b))
-#define zgzezh(r,a,b) r=((I_)(a))>=((I_)(b))
-#define zezezh(r,a,b) r=((I_)(a))==((I_)(b))
-#define zszezh(r,a,b) r=((I_)(a))!=((I_)(b))
-#define zlzh(r,a,b) r=((I_)(a))< ((I_)(b))
-#define zlzezh(r,a,b) r=((I_)(a))<=((I_)(b))
-
-#define gtWordzh(r,a,b) r=((W_)(a))> ((W_)(b))
-#define geWordzh(r,a,b) r=((W_)(a))>=((W_)(b))
-#define eqWordzh(r,a,b) r=((W_)(a))==((W_)(b))
-#define neWordzh(r,a,b) r=((W_)(a))!=((W_)(b))
-#define ltWordzh(r,a,b) r=((W_)(a))< ((W_)(b))
-#define leWordzh(r,a,b) r=((W_)(a))<=((W_)(b))
-
-#define gtAddrzh(r,a,b) r=((A_)(a))> ((A_)(b))
-#define geAddrzh(r,a,b) r=((A_)(a))>=((A_)(b))
-#define eqAddrzh(r,a,b) r=((A_)(a))==((A_)(b))
-#define neAddrzh(r,a,b) r=((A_)(a))!=((A_)(b))
-#define ltAddrzh(r,a,b) r=((A_)(a))< ((A_)(b))
-#define leAddrzh(r,a,b) r=((A_)(a))<=((A_)(b))
-
-#define gtFloatzh(r,a,b) r=((StgFloat)(a))> ((StgFloat)(b))
-#define geFloatzh(r,a,b) r=((StgFloat)(a))>=((StgFloat)(b))
-#define eqFloatzh(r,a,b) r=((StgFloat)(a))==((StgFloat)(b))
-#define neFloatzh(r,a,b) r=((StgFloat)(a))!=((StgFloat)(b))
-#define ltFloatzh(r,a,b) r=((StgFloat)(a))< ((StgFloat)(b))
-#define leFloatzh(r,a,b) r=((StgFloat)(a))<=((StgFloat)(b))
-
-/* Double comparisons: >##, >=## etc */
-#define zgzhzh(r,a,b) r=((StgDouble)(a))> ((StgDouble)(b))
-#define zgzezhzh(r,a,b) r=((StgDouble)(a))>=((StgDouble)(b))
-#define zezezhzh(r,a,b) r=((StgDouble)(a))==((StgDouble)(b))
-#define zszezhzh(r,a,b) r=((StgDouble)(a))!=((StgDouble)(b))
-#define zlzhzh(r,a,b) r=((StgDouble)(a))< ((StgDouble)(b))
-#define zlzezhzh(r,a,b) r=((StgDouble)(a))<=((StgDouble)(b))
-
-/* -----------------------------------------------------------------------------
- Char# PrimOps.
- -------------------------------------------------------------------------- */
-
-#define ordzh(r,a) r=(I_)(a)
-#define chrzh(r,a) r=(C_)(a)
-
-/* -----------------------------------------------------------------------------
- Int# PrimOps.
- -------------------------------------------------------------------------- */
-
-#define zpzh(r,a,b) r=((I_)(a))+((I_)(b))
-#define zmzh(r,a,b) r=((I_)(a))-((I_)(b))
-#define ztzh(r,a,b) r=((I_)(a))*((I_)(b))
-#define quotIntzh(r,a,b) r=((I_)(a))/((I_)(b))
-#define remIntzh(r,a,b) r=((I_)(a))%((I_)(b))
-#define negateIntzh(r,a) r=-((I_)(a))
/* -----------------------------------------------------------------------------
* Int operations with carry.
}
#endif
-/* -----------------------------------------------------------------------------
- Word# PrimOps.
- -------------------------------------------------------------------------- */
-
-#define plusWordzh(r,a,b) r=((W_)(a))+((W_)(b))
-#define minusWordzh(r,a,b) r=((W_)(a))-((W_)(b))
-#define timesWordzh(r,a,b) r=((W_)(a))*((W_)(b))
-#define quotWordzh(r,a,b) r=((W_)(a))/((W_)(b))
-#define remWordzh(r,a,b) r=((W_)(a))%((W_)(b))
-
-#define andzh(r,a,b) r=((W_)(a))&((W_)(b))
-#define orzh(r,a,b) r=((W_)(a))|((W_)(b))
-#define xorzh(r,a,b) r=((W_)(a))^((W_)(b))
-#define notzh(r,a) r=~((W_)(a))
-
-/* The extra tests below properly define the behaviour when shifting
- * by offsets larger than the width of the value being shifted. Doing
- * so is undefined in C (and in fact gives different answers depending
- * on whether the operation is constant folded or not with gcc on x86!)
- */
-
-#define shiftLzh(r,a,b) r=(((I_)(b)) >= BITS_IN(W_)) ? 0 : ((W_)(a))<<((I_)(b))
-#define shiftRLzh(r,a,b) r=(((I_)(b)) >= BITS_IN(W_)) ? 0 : ((W_)(a))>>((I_)(b))
-#define iShiftLzh(r,a,b) r=(((I_)(b)) >= BITS_IN(W_)) ? 0 : ((W_)(a))<<((I_)(b))
-/* Right shifting of signed quantities is not portable in C, so
- the behaviour you'll get from using these primops depends
- on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98
-*/
-#define iShiftRAzh(r,a,b) r=(((I_)(b)) >= BITS_IN(I_)) ? ((((I_)(a)) < 0) ? -1 : 0) : ((I_)(a))>>((I_)(b))
-#define iShiftRLzh(r,a,b) r=(((I_)(b)) >= BITS_IN(I_)) ? 0 : (I_)((W_)((I_)(a))>>((I_)(b)))
-
-#define int2Wordzh(r,a) r=(W_)((I_)(a))
-#define word2Intzh(r,a) r=(I_)((W_)(a))
-
-/* -----------------------------------------------------------------------------
- Explicitly sized Int# and Word# PrimOps.
- -------------------------------------------------------------------------- */
-
-#define narrow8Intzh(r,a) r=(StgInt8)((I_)(a))
-#define narrow16Intzh(r,a) r=(StgInt16)((I_)(a))
-#define narrow32Intzh(r,a) r=(StgInt32)((I_)(a))
-#define narrow8Wordzh(r,a) r=(StgWord8)((W_)(a))
-#define narrow16Wordzh(r,a) r=(StgWord16)((W_)(a))
-#define narrow32Wordzh(r,a) r=(StgWord32)((W_)(a))
-
-/* -----------------------------------------------------------------------------
- Addr# PrimOps.
- -------------------------------------------------------------------------- */
-
-#define nullAddrzh(r,i) r=(A_)(0)
-#define plusAddrzh(r,a,i) r=((char *)(a)) + (i)
-#define minusAddrzh(r,a,b) r=((char *)(a)) - ((char *)(b))
-#define remAddrzh(r,a,i) r=((W_)(a))%(i)
-#define int2Addrzh(r,a) r=(A_)(a)
-#define addr2Intzh(r,a) r=(I_)(a)
-
-#define readCharOffAddrzh(r,a,i) r=((StgWord8 *)(a))[i]
-#define readWideCharOffAddrzh(r,a,i) r=((C_ *)(a))[i]
-#define readIntOffAddrzh(r,a,i) r=((I_ *)(a))[i]
-#define readWordOffAddrzh(r,a,i) r=((W_ *)(a))[i]
-#define readAddrOffAddrzh(r,a,i) r=((PP_)(a))[i]
-#define readFloatOffAddrzh(r,a,i) r=PK_FLT((P_) (((StgFloat *)(a)) + i))
-#define readDoubleOffAddrzh(r,a,i) r=PK_DBL((P_) (((StgDouble *)(a)) + i))
-#define readStablePtrOffAddrzh(r,a,i) r=((StgStablePtr *)(a))[i]
-#define readInt8OffAddrzh(r,a,i) r=((StgInt8 *)(a))[i]
-#define readInt16OffAddrzh(r,a,i) r=((StgInt16 *)(a))[i]
-#define readWord8OffAddrzh(r,a,i) r=((StgWord8 *)(a))[i]
-#define readWord16OffAddrzh(r,a,i) r=((StgWord16 *)(a))[i]
-#define readInt32OffAddrzh(r,a,i) r=((StgInt32 *)(a))[i]
-#define readWord32OffAddrzh(r,a,i) r=((StgWord32 *)(a))[i]
-#ifdef SUPPORT_LONG_LONGS
-#define readInt64OffAddrzh(r,a,i) r=((LI_ *)(a))[i]
-#define readWord64OffAddrzh(r,a,i) r=((LW_ *)(a))[i]
-#else
-#define readInt64OffAddrzh(r,a,i) r=((I_ *)(a))[i]
-#define readWord64OffAddrzh(r,a,i) r=((W_ *)(a))[i]
-#endif
-
-#define writeCharOffAddrzh(a,i,v) ((StgWord8 *)(a))[i] = (v)
-#define writeWideCharOffAddrzh(a,i,v) ((C_ *)(a))[i] = (v)
-#define writeIntOffAddrzh(a,i,v) ((I_ *)(a))[i] = (v)
-#define writeWordOffAddrzh(a,i,v) ((W_ *)(a))[i] = (v)
-#define writeAddrOffAddrzh(a,i,v) ((PP_)(a))[i] = (v)
-#define writeForeignObjOffAddrzh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
-#define writeFloatOffAddrzh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
-#define writeDoubleOffAddrzh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
-#define writeStablePtrOffAddrzh(a,i,v) ((StgStablePtr *)(a))[i] = (v)
-#define writeInt8OffAddrzh(a,i,v) ((StgInt8 *)(a))[i] = (v)
-#define writeInt16OffAddrzh(a,i,v) ((StgInt16 *)(a))[i] = (v)
-#define writeInt32OffAddrzh(a,i,v) ((StgInt32 *)(a))[i] = (v)
-#define writeWord8OffAddrzh(a,i,v) ((StgWord8 *)(a))[i] = (v)
-#define writeWord16OffAddrzh(a,i,v) ((StgWord16 *)(a))[i] = (v)
-#define writeWord32OffAddrzh(a,i,v) ((StgWord32 *)(a))[i] = (v)
-#ifdef SUPPORT_LONG_LONGS
-#define writeInt64OffAddrzh(a,i,v) ((LI_ *)(a))[i] = (v)
-#define writeWord64OffAddrzh(a,i,v) ((LW_ *)(a))[i] = (v)
-#else
-#define writeInt64OffAddrzh(a,i,v) ((I_ *)(a))[i] = (v)
-#define writeWord64OffAddrzh(a,i,v) ((W_ *)(a))[i] = (v)
-#endif
-
-#define indexCharOffAddrzh(r,a,i) r=((StgWord8 *)(a))[i]
-#define indexWideCharOffAddrzh(r,a,i) r=((C_ *)(a))[i]
-#define indexIntOffAddrzh(r,a,i) r=((I_ *)(a))[i]
-#define indexWordOffAddrzh(r,a,i) r=((W_ *)(a))[i]
-#define indexAddrOffAddrzh(r,a,i) r=((PP_)(a))[i]
-#define indexFloatOffAddrzh(r,a,i) r=PK_FLT((P_) (((StgFloat *)(a)) + i))
-#define indexDoubleOffAddrzh(r,a,i) r=PK_DBL((P_) (((StgDouble *)(a)) + i))
-#define indexStablePtrOffAddrzh(r,a,i) r=((StgStablePtr *)(a))[i]
-#define indexInt8OffAddrzh(r,a,i) r=((StgInt8 *)(a))[i]
-#define indexInt16OffAddrzh(r,a,i) r=((StgInt16 *)(a))[i]
-#define indexInt32OffAddrzh(r,a,i) r=((StgInt32 *)(a))[i]
-#define indexWord8OffAddrzh(r,a,i) r=((StgWord8 *)(a))[i]
-#define indexWord16OffAddrzh(r,a,i) r=((StgWord16 *)(a))[i]
-#define indexWord32OffAddrzh(r,a,i) r=((StgWord32 *)(a))[i]
-#ifdef SUPPORT_LONG_LONGS
-#define indexInt64OffAddrzh(r,a,i) r=((LI_ *)(a))[i]
-#define indexWord64OffAddrzh(r,a,i) r=((LW_ *)(a))[i]
-#else
-#define indexInt64OffAddrzh(r,a,i) r=((I_ *)(a))[i]
-#define indexWord64OffAddrzh(r,a,i) r=((W_ *)(a))[i]
-#endif
-
-/* -----------------------------------------------------------------------------
- Float PrimOps.
- -------------------------------------------------------------------------- */
-
-#define plusFloatzh(r,a,b) r=((StgFloat)(a))+((StgFloat)(b))
-#define minusFloatzh(r,a,b) r=((StgFloat)(a))-((StgFloat)(b))
-#define timesFloatzh(r,a,b) r=((StgFloat)(a))*((StgFloat)(b))
-#define divideFloatzh(r,a,b) r=((StgFloat)(a))/((StgFloat)(b))
-#define negateFloatzh(r,a) r=-((StgFloat)(a))
-
-#define int2Floatzh(r,a) r=(StgFloat)((I_)(a))
-#define float2Intzh(r,a) r=(I_)((StgFloat)(a))
-
-#define expFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,exp,((StgFloat)(a)))
-#define logFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,log,((StgFloat)(a)))
-#define sqrtFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sqrt,((StgFloat)(a)))
-#define sinFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sin,((StgFloat)(a)))
-#define cosFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cos,((StgFloat)(a)))
-#define tanFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tan,((StgFloat)(a)))
-#define asinFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,asin,((StgFloat)(a)))
-#define acosFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,acos,((StgFloat)(a)))
-#define atanFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,atan,((StgFloat)(a)))
-#define sinhFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,sinh,((StgFloat)(a)))
-#define coshFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,cosh,((StgFloat)(a)))
-#define tanhFloatzh(r,a) r=(StgFloat) RET_PRIM_STGCALL1(StgDouble,tanh,((StgFloat)(a)))
-#define powerFloatzh(r,a,b) r=(StgFloat) RET_PRIM_STGCALL2(StgDouble,pow,((StgFloat)(a)),((StgFloat)(b)))
-
-/* -----------------------------------------------------------------------------
- Double PrimOps.
- -------------------------------------------------------------------------- */
-
-#define zpzhzh(r,a,b) r=((StgDouble)(a))+((StgDouble)(b))
-#define zmzhzh(r,a,b) r=((StgDouble)(a))-((StgDouble)(b))
-#define ztzhzh(r,a,b) r=((StgDouble)(a))*((StgDouble)(b))
-#define zszhzh(r,a,b) r=((StgDouble)(a))/((StgDouble)(b))
-#define negateDoublezh(r,a) r=-((StgDouble)(a))
-
-#define int2Doublezh(r,a) r=(StgDouble)((I_)(a))
-#define double2Intzh(r,a) r=(I_)((StgDouble)(a))
-
-#define float2Doublezh(r,a) r=(StgDouble)((StgFloat)(a))
-#define double2Floatzh(r,a) r=(StgFloat)((StgDouble)(a))
-
-#define expDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,exp,((StgDouble)(a)))
-#define logDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,log,((StgDouble)(a)))
-#define sqrtDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sqrt,((StgDouble)(a)))
-#define sinDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sin,((StgDouble)(a)))
-#define cosDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cos,((StgDouble)(a)))
-#define tanDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tan,((StgDouble)(a)))
-#define asinDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,asin,((StgDouble)(a)))
-#define acosDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,acos,((StgDouble)(a)))
-#define atanDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,atan,((StgDouble)(a)))
-#define sinhDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,sinh,((StgDouble)(a)))
-#define coshDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,cosh,((StgDouble)(a)))
-#define tanhDoublezh(r,a) r=(StgDouble) RET_PRIM_STGCALL1(StgDouble,tanh,((StgDouble)(a)))
-/* Power: **## */
-#define ztztzhzh(r,a,b) r=(StgDouble) RET_PRIM_STGCALL2(StgDouble,pow,((StgDouble)(a)),((StgDouble)(b)))
/* -----------------------------------------------------------------------------
Integer PrimOps.
-------------------------------------------------------------------------- */
-/* We can do integer2Int and cmpInteger inline, since they don't need
- * to allocate any memory.
- *
- * integer2Int# is now modular.
- */
-
-#define integer2Intzh(r, sa,da) \
-{ I_ s, res; \
- \
- s = (sa); \
- if (s == 0) \
- res = 0; \
- else { \
- res = ((mp_limb_t *) (BYTE_ARR_CTS(da)))[0]; \
- if (s < 0) res = -res; \
- } \
- (r) = res; \
-}
-
-#define integer2Wordzh(r, sa,da) \
-{ I_ s; \
- W_ res; \
- \
- s = (sa); \
- if (s == 0) \
- res = 0; \
- else { \
- res = ((mp_limb_t *) (BYTE_ARR_CTS(da)))[0]; \
- if (s < 0) res = -res; \
- } \
- (r) = res; \
-}
-
-#define cmpIntegerzh(r, s1,d1, s2,d2) \
-{ MP_INT arg1; \
- MP_INT arg2; \
- \
- arg1._mp_size = (s1); \
- arg1._mp_alloc= ((StgArrWords *)d1)->words; \
- arg1._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(d1)); \
- arg2._mp_size = (s2); \
- arg2._mp_alloc= ((StgArrWords *)d2)->words; \
- arg2._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(d2)); \
- \
- (r) = RET_PRIM_STGCALL2(I_,mpz_cmp,&arg1,&arg2); \
-}
-
-#define cmpIntegerIntzh(r, s,d, i) \
-{ MP_INT arg; \
- \
- arg._mp_size = (s); \
- arg._mp_alloc = ((StgArrWords *)d)->words; \
- arg._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(d)); \
- \
- (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i); \
-}
-
/* NOTE: gcdIntzh and gcdIntegerIntzh work only for positive inputs! */
-/* mp_limb_t must be able to hold an StgInt for this to work properly */
-#define gcdIntzh(r,a,b) \
-{ mp_limb_t aa = (mp_limb_t)(a); \
- r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(b)); \
-}
-
-#define gcdIntegerIntzh(r,sa,a,b) \
- r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(BYTE_ARR_CTS(a)), sa, b)
-
-/* The rest are all out-of-line: -------- */
+/* Some of these are out-of-line: -------- */
/* Integer arithmetic */
EXTFUN_RTS(plusIntegerzh_fast);
EXTFUN_RTS(divExactIntegerzh_fast);
EXTFUN_RTS(divModIntegerzh_fast);
+EXTFUN_RTS(cmpIntegerIntzh_fast);
+EXTFUN_RTS(cmpIntegerzh_fast);
+EXTFUN_RTS(integer2Intzh_fast);
+EXTFUN_RTS(integer2Wordzh_fast);
+EXTFUN_RTS(gcdIntegerIntzh_fast);
+EXTFUN_RTS(gcdIntzh_fast);
+
/* Conversions */
EXTFUN_RTS(int2Integerzh_fast);
EXTFUN_RTS(word2Integerzh_fast);
EXTFUN_RTS(xorIntegerzh_fast);
EXTFUN_RTS(complementIntegerzh_fast);
+
/* -----------------------------------------------------------------------------
Word64 PrimOps.
-------------------------------------------------------------------------- */
#ifdef SUPPORT_LONG_LONGS
-#define integerToWord64zh(r,sa,da) \
-{ mp_limb_t* d; \
- I_ s; \
- StgWord64 res; \
- \
- d = (mp_limb_t *) (BYTE_ARR_CTS(da)); \
- s = (sa); \
- switch (s) { \
- case 0: res = 0; break; \
- case 1: res = d[0]; break; \
- case -1: res = -d[0]; break; \
- default: \
- res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t))); \
- if (s < 0) res = -res; \
- } \
- (r) = res; \
-}
-
-#define integerToInt64zh(r,sa,da) \
-{ mp_limb_t* d; \
- I_ s; \
- StgInt64 res; \
- \
- d = (mp_limb_t *) (BYTE_ARR_CTS(da)); \
- s = (sa); \
- switch (s) { \
- case 0: res = 0; break; \
- case 1: res = d[0]; break; \
- case -1: res = -d[0]; break; \
- default: \
- res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t))); \
- if (s < 0) res = -res; \
- } \
- (r) = res; \
-}
-
/* Conversions */
EXTFUN_RTS(int64ToIntegerzh_fast);
EXTFUN_RTS(word64ToIntegerzh_fast);
-/* The rest are (way!) out of line, implemented via C entry points.
- */
+/* The rest are (way!) out of line, implemented in vanilla C. */
I_ stg_gtWord64 (StgWord64, StgWord64);
I_ stg_geWord64 (StgWord64, StgWord64);
I_ stg_eqWord64 (StgWord64, StgWord64);
LW_ stg_wordToWord64 (StgWord);
W_ stg_word64ToWord (StgWord64);
LI_ stg_word64ToInt64 (StgWord64);
+
+LI_ stg_integerToInt64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da);
+LW_ stg_integerToWord64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da);
+
#endif
/* -----------------------------------------------------------------------------
#define PTRS_ARR_CTS(a) REAL_PTRS_ARR_CTS(a)
#endif
+
extern I_ genSymZh(void);
extern I_ resetGenSymZh(void);
-/*--- everything except new*Array is done inline: */
-
-#define sameMutableArrayzh(r,a,b) r=(I_)((a)==(b))
-#define sameMutableByteArrayzh(r,a,b) r=(I_)((a)==(b))
-
-#define readArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
-
-#define readCharArrayzh(r,a,i) indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readWideCharArrayzh(r,a,i) indexWideCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readIntArrayzh(r,a,i) indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readWordArrayzh(r,a,i) indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readAddrArrayzh(r,a,i) indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readFloatArrayzh(r,a,i) indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readInt8Arrayzh(r,a,i) indexInt8OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readInt16Arrayzh(r,a,i) indexInt16OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readInt32Arrayzh(r,a,i) indexInt32OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readWord8Arrayzh(r,a,i) indexWord8OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readWord16Arrayzh(r,a,i) indexWord16OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readWord32Arrayzh(r,a,i) indexWord32OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
-
-/* result ("r") arg ignored in write macros! */
-#define writeArrayzh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
-
-#define writeCharArrayzh(a,i,v) writeCharOffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeWideCharArrayzh(a,i,v) writeWideCharOffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeIntArrayzh(a,i,v) writeIntOffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeWordArrayzh(a,i,v) writeWordOffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeAddrArrayzh(a,i,v) writeAddrOffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeFloatArrayzh(a,i,v) writeFloatOffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeDoubleArrayzh(a,i,v) writeDoubleOffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeStablePtrArrayzh(a,i,v) writeStablePtrOffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeInt8Arrayzh(a,i,v) writeInt8OffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeInt16Arrayzh(a,i,v) writeInt16OffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeInt32Arrayzh(a,i,v) writeInt32OffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeWord8Arrayzh(a,i,v) writeWord8OffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeWord16Arrayzh(a,i,v) writeWord16OffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeWord32Arrayzh(a,i,v) writeWord32OffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeInt64Arrayzh(a,i,v) writeInt64OffAddrzh(BYTE_ARR_CTS(a),i,v)
-#define writeWord64Arrayzh(a,i,v) writeWord64OffAddrzh(BYTE_ARR_CTS(a),i,v)
-
-#define indexArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
-
-#define indexCharArrayzh(r,a,i) indexCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexWideCharArrayzh(r,a,i) indexWideCharOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexIntArrayzh(r,a,i) indexIntOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexWordArrayzh(r,a,i) indexWordOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexAddrArrayzh(r,a,i) indexAddrOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexFloatArrayzh(r,a,i) indexFloatOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexDoubleArrayzh(r,a,i) indexDoubleOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexStablePtrArrayzh(r,a,i) indexStablePtrOffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexInt8Arrayzh(r,a,i) indexInt8OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexInt16Arrayzh(r,a,i) indexInt16OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexInt32Arrayzh(r,a,i) indexInt32OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexWord8Arrayzh(r,a,i) indexWord8OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexWord16Arrayzh(r,a,i) indexWord16OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexWord32Arrayzh(r,a,i) indexWord32OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i)
-#define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i)
-
-/* Freezing arrays-of-ptrs requires changing an info table, for the
- benefit of the generational collector. It needs to scavenge mutable
- objects, even if they are in old space. When they become immutable,
- they can be removed from this scavenge list. */
-
-#define unsafeFreezzeArrayzh(r,a) \
- { \
- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); \
- r = a; \
- }
-
-#define unsafeFreezzeByteArrayzh(r,a) r=(a)
+/*--- Almost everything in line. */
EXTFUN_RTS(unsafeThawArrayzh_fast);
-
-#define sizzeofByteArrayzh(r,a) \
- r = (((StgArrWords *)(a))->words * sizeof(W_))
-#define sizzeofMutableByteArrayzh(r,a) \
- r = (((StgArrWords *)(a))->words * sizeof(W_))
-
-/* and the out-of-line ones... */
-
EXTFUN_RTS(newByteArrayzh_fast);
EXTFUN_RTS(newPinnedByteArrayzh_fast);
EXTFUN_RTS(newArrayzh_fast);
-// Highly unsafe, for use with a pinned ByteArray
-// being kept alive with touch#
-#define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
-
-/* encoding and decoding of floats/doubles. */
-
-/* We only support IEEE floating point format */
-#include "ieee-flpt.h"
-
/* The decode operations are out-of-line because they need to allocate
* a byte array.
*/
+
+/* We only support IEEE floating point formats. */
+#include "ieee-flpt.h"
EXTFUN_RTS(decodeFloatzh_fast);
EXTFUN_RTS(decodeDoublezh_fast);
/* grimy low-level support functions defined in StgPrimFloat.c */
-
extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
extern StgDouble __int_encodeDouble (I_ j, I_ e);
extern StgFloat __encodeFloat (I_ size, StgByteArray arr, I_ e);
extern StgInt isFloatDenormalized(StgFloat f);
extern StgInt isFloatNegativeZero(StgFloat f);
+
/* -----------------------------------------------------------------------------
Mutable variables
EXTFUN_RTS(newMutVarzh_fast);
-#define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var)
-#define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
-#define sameMutVarzh(r,a,b) r=(I_)((a)==(b))
/* -----------------------------------------------------------------------------
MVar PrimOps.
All out of line, because they either allocate or may block.
-------------------------------------------------------------------------- */
-#define sameMVarzh(r,a,b) r=(I_)((a)==(b))
-/* Assume external decl of EMPTY_MVAR_info is in scope by now */
-#define isEmptyMVarzh(r,a) r=(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info )
+EXTFUN_RTS(isEmptyMVarzh_fast);
EXTFUN_RTS(newMVarzh_fast);
EXTFUN_RTS(takeMVarzh_fast);
EXTFUN_RTS(putMVarzh_fast);
EXTFUN_RTS(tryTakeMVarzh_fast);
EXTFUN_RTS(tryPutMVarzh_fast);
+
/* -----------------------------------------------------------------------------
Delay/Wait PrimOps
-------------------------------------------------------------------------- */
EXTFUN_RTS(waitWritezh_fast);
EXTFUN_RTS(delayzh_fast);
+
/* -----------------------------------------------------------------------------
Primitive I/O, error-handling PrimOps
-------------------------------------------------------------------------- */
extern void stg_exit(I_ n) __attribute__ ((noreturn));
+
/* -----------------------------------------------------------------------------
Stable Name / Stable Pointer PrimOps
-------------------------------------------------------------------------- */
EXTFUN_RTS(makeStableNamezh_fast);
+EXTFUN_RTS(makeStablePtrzh_fast);
+EXTFUN_RTS(deRefStablePtrzh_fast);
-#define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
-
-#define eqStableNamezh(r,sn1,sn2) \
- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
-
-#define makeStablePtrzh(r,a) \
- r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
-
-#define deRefStablePtrzh(r,sp) do { \
- ASSERT(stable_ptr_table[(StgWord)sp].ref > 0); \
- r = stable_ptr_table[(StgWord)sp].addr; \
-} while (0);
-
-#define eqStablePtrzh(r,sp1,sp2) \
- (r = ((StgWord)sp1 == (StgWord)sp2))
/* -----------------------------------------------------------------------------
Concurrency/Exception PrimOps.
EXTFUN_RTS(seqzh_fast);
EXTFUN_RTS(blockAsyncExceptionszh_fast);
EXTFUN_RTS(unblockAsyncExceptionszh_fast);
-
-#define myThreadIdzh(t) (t = CurrentTSO)
+EXTFUN_RTS(myThreadIdzh_fast);
extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2);
extern int rts_getThreadId(const StgTSO *tso);
+
+/* -----------------------------------------------------------------------------
+ Weak Pointer PrimOps.
+ -------------------------------------------------------------------------- */
+
+EXTFUN_RTS(mkWeakzh_fast);
+EXTFUN_RTS(finalizzeWeakzh_fast);
+EXTFUN_RTS(deRefWeakzh_fast);
+
+
+/* -----------------------------------------------------------------------------
+ Foreign Object PrimOps.
+ -------------------------------------------------------------------------- */
+
+EXTFUN_RTS(mkForeignObjzh_fast);
+
+
+/* -----------------------------------------------------------------------------
+ BCOs and BCO linkery
+ -------------------------------------------------------------------------- */
+
+EXTFUN_RTS(newBCOzh_fast);
+EXTFUN_RTS(mkApUpd0zh_fast);
+
+
+/* -----------------------------------------------------------------------------
+ Signal handling. Not really primops, but called directly from Haskell.
+ -------------------------------------------------------------------------- */
+
+#define STG_SIG_DFL (-1)
+#define STG_SIG_IGN (-2)
+#define STG_SIG_ERR (-3)
+#define STG_SIG_HAN (-4)
+
+extern StgInt stg_sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
+#define stg_sig_default(sig,mask) stg_sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
+#define stg_sig_ignore(sig,mask) stg_sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
+#define stg_sig_catch(sig,ptr,mask) stg_sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
+
+
/* ------------------------------------------------------------------------
Parallel PrimOps
#define parzh(r,node) r = 1
#endif
-/* -----------------------------------------------------------------------------
- Pointer equality
- -------------------------------------------------------------------------- */
-
-/* warning: extremely non-referentially transparent, need to hide in
- an appropriate monad.
-
- ToDo: follow indirections.
-*/
-
-#define reallyUnsafePtrEqualityzh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
-
-/* -----------------------------------------------------------------------------
- Weak Pointer PrimOps.
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(mkWeakzh_fast);
-EXTFUN_RTS(finalizzeWeakzh_fast);
-
-#define deRefWeakzh(code,val,w) \
- if (((StgWeak *)w)->header.info == &stg_WEAK_info) { \
- code = 1; \
- val = (P_)((StgWeak *)w)->value; \
- } else { \
- code = 0; \
- val = (P_)w; \
- }
-
-#define sameWeakzh(w1,w2) ((w1)==(w2))
-
-
-/* -----------------------------------------------------------------------------
- Foreign Object PrimOps.
- -------------------------------------------------------------------------- */
-
-#define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
-
-#define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo)
-#define touchzh(o) /* nothing */
-
-EXTFUN_RTS(mkForeignObjzh_fast);
-
-#define writeForeignObjzh(res,datum) \
- (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
-
-#define eqForeignObjzh(r,f1,f2) r=(f1)==(f2)
-#define indexCharOffForeignObjzh(r,fo,i) indexCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexWideCharOffForeignObjzh(r,fo,i) indexWideCharOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexIntOffForeignObjzh(r,fo,i) indexIntOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexWordOffForeignObjzh(r,fo,i) indexWordOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexAddrOffForeignObjzh(r,fo,i) indexAddrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexFloatOffForeignObjzh(r,fo,i) indexFloatOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexDoubleOffForeignObjzh(r,fo,i) indexDoubleOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexStablePtrOffForeignObjzh(r,fo,i) indexStablePtrOffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexInt8OffForeignObjzh(r,fo,i) indexInt8OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexInt16OffForeignObjzh(r,fo,i) indexInt16OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexInt32OffForeignObjzh(r,fo,i) indexInt32OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexWord8OffForeignObjzh(r,fo,i) indexWord8OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexWord16OffForeignObjzh(r,fo,i) indexWord16OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexWord32OffForeignObjzh(r,fo,i) indexWord32OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexInt64OffForeignObjzh(r,fo,i) indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-#define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
-
-/* -----------------------------------------------------------------------------
- Constructor tags
- -------------------------------------------------------------------------- */
-
-#define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
-
-/* tagToEnum# is handled directly by the code generator. */
-
-/* -----------------------------------------------------------------------------
- BCOs and BCO linkery
- -------------------------------------------------------------------------- */
-
-EXTFUN_RTS(newBCOzh_fast);
-EXTFUN_RTS(mkApUpd0zh_fast);
-
-/* -----------------------------------------------------------------------------
- Signal processing. Not really primops, but called directly from
- Haskell.
- -------------------------------------------------------------------------- */
-
-#define STG_SIG_DFL (-1)
-#define STG_SIG_IGN (-2)
-#define STG_SIG_ERR (-3)
-#define STG_SIG_HAN (-4)
-
-extern StgInt stg_sig_install (StgInt, StgInt, StgStablePtr, sigset_t *);
-#define stg_sig_default(sig,mask) stg_sig_install(sig,STG_SIG_DFL,0,(sigset_t *)mask)
-#define stg_sig_ignore(sig,mask) stg_sig_install(sig,STG_SIG_IGN,0,(sigset_t *)mask)
-#define stg_sig_catch(sig,ptr,mask) stg_sig_install(sig,STG_SIG_HAN,ptr,(sigset_t *)mask)
-
#endif /* PRIMOPS_H */
/* -----------------------------------------------------------------------------
- * $Id: Stg.h,v 1.42 2001/11/26 16:54:22 simonmar Exp $
+ * $Id: Stg.h,v 1.43 2001/12/05 17:35:14 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "StgTicky.h"
#include "CCall.h"
#include "Stable.h"
+#include "PrimOpHelpers.h"
/* Built-in entry points */
#include "StgMiscClosures.h"
word32ToIntegerzh
#endif
#if WORD_SIZE_IN_BITS < 64
- integerToInt64zh
- integerToWord64zh
int64ToIntegerzh
word64ToIntegerzh
#endif
eqStableNamezh
stableNameToIntzh
- reallyUnsafePtrEqualityzh
-
newBCOzh
BCOzh
mkApUpd0zh
foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64#
foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64#
+foreign import "stg_integerToInt64" unsafe integerToInt64# :: Int# -> ByteArray# -> Int64#
+
{-# RULES
"fromIntegral/Int->Int64" fromIntegral = \(I# x#) -> I64# (intToInt64# x#)
"fromIntegral/Word->Int64" fromIntegral = \(W# x#) -> I64# (word64ToInt64# (wordToWord64# x#))
foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64#
foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64#
+foreign import "stg_integerToWord64" unsafe integerToWord64# :: Int# -> ByteArray# -> Word64#
+
+
{-# RULES
"fromIntegral/Int->Word64" fromIntegral = \(I# x#) -> W64# (int64ToWord64# (intToInt64# x#))
"fromIntegral/Word->Word64" fromIntegral = \(W# x#) -> W64# (wordToWord64# x#)
/* -----------------------------------------------------------------------------
- * $Id: longlong.c,v 1.3 2001/07/23 15:11:55 simonmar Exp $
+ * $Id: longlong.c,v 1.4 2001/12/05 17:35:15 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
StgInt64 stg_iShiftRL64 (StgInt64 a, StgInt b)
{return (StgInt64) ((StgWord64) a >> b);}
-/* Casting between longs and longer longs:
- (the primops that cast between Integers and long longs are
+/* Casting between longs and longer longs.
+ (the primops that cast from long longs to Integers
expressed as macros, since these may cause some heap allocation).
*/
StgWord stg_word64ToWord (StgWord64 w) {return (StgWord) w;}
StgInt64 stg_word64ToInt64 (StgWord64 w) {return (StgInt64) w;}
+StgWord64 stg_integerToWord64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da)
+{
+ mp_limb_t* d;
+ I_ s;
+ StgWord64 res;
+ d = (mp_limb_t *)da;
+ s = sa;
+ switch (s) {
+ case 0: res = 0; break;
+ case 1: res = d[0]; break;
+ case -1: res = -d[0]; break;
+ default:
+ res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t)));
+ if (s < 0) res = -res;
+ }
+ return res;
+}
+
+StgInt64 stg_integerToInt64 (StgInt sa, StgByteArray /* Really: mp_limb_t* */ da)
+{
+ mp_limb_t* d;
+ I_ s;
+ StgInt64 res;
+ d = (mp_limb_t *)da;
+ s = (sa);
+ switch (s) {
+ case 0: res = 0; break;
+ case 1: res = d[0]; break;
+ case -1: res = -d[0]; break;
+ default:
+ res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t)));
+ if (s < 0) res = -res;
+ }
+ return res;
+}
+
#endif /* SUPPORT_LONG_LONGS */
/* -----------------------------------------------------------------------------
- * $Id: Exception.hc,v 1.22 2001/11/22 14:25:12 simonmar Exp $
+ * $Id: Exception.hc,v 1.23 2001/12/05 17:35:15 sewardj Exp $
*
* (c) The GHC Team, 1998-2000
*
FE_
}
+
+FN_(myThreadIdzh_fast)
+{
+ /* no args. */
+ FB_
+ R1.p = (P_)CurrentTSO;
+ JMP_(ENTRY_CODE(Sp[0]));
+ FE_
+}
+
+
/* -----------------------------------------------------------------------------
Catch frames
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.85 2001/11/22 14:25:12 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.86 2001/12/05 17:35:15 sewardj Exp $
*
* (c) The GHC Team, 1998-2000
*
/* -----------------------------------------------------------------------------
Foreign Object Primitives
-
-------------------------------------------------------------------------- */
FN_(mkForeignObjzh_fast)
FE_
}
+FN_(deRefWeakzh_fast)
+{
+ /* R1.p = weak ptr */
+ StgWeak* w;
+ I_ code;
+ P_ val;
+ FB_
+ w = (StgWeak*)R1.p;
+ if (w->header.info == &stg_WEAK_info) {
+ code = 1;
+ val = (P_)((StgWeak *)w)->value;
+ } else {
+ code = 0;
+ val = (P_)w;
+ }
+ RET_NP(code,val);
+ FE_
+}
+
/* -----------------------------------------------------------------------------
Arbitrary-precision Integer operations.
-------------------------------------------------------------------------- */
GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
GMP_TAKE2_RET2(divModIntegerzh_fast, mpz_fdiv_qr);
+
+FN_(gcdIntzh_fast)
+{
+ /* R1 = the first Int#; R2 = the second Int# */
+ mp_limb_t aa;
+ I_ r;
+ FB_
+ aa = (mp_limb_t)(R1.i);
+ r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(R2.i));
+ RET_N(r);
+ FE_
+}
+
+FN_(gcdIntegerIntzh_fast)
+{
+ /* R1 = s1; R2 = d1; R3 = the int */
+ I_ r;
+ FB_
+ MAYBE_GC(R2_PTR, gcdIntegerIntzh_fast);
+ r = RET_STGCALL3(I_,mpn_gcd_1,(mp_limb_t *)(BYTE_ARR_CTS(R2.p)), R1.i, R3.i);
+ RET_N(r);
+ FE_
+}
+
+FN_(cmpIntegerIntzh_fast)
+{
+ /* R1 = s1; R2 = d1; R3 = the int */
+ MP_INT arg;
+ I_ r;
+ FB_
+ MAYBE_GC(R2_PTR, cmpIntegerIntzh_fast);
+ arg._mp_size = R1.i;
+ arg._mp_alloc = ((StgArrWords *)R2.p)->words;
+ arg._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(R2.p));
+ r = RET_STGCALL2(I_,mpz_cmp_si,&arg,R3.i);
+ RET_N(r);
+ FE_
+}
+
+FN_(cmpIntegerzh_fast)
+{
+ /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
+ MP_INT arg1, arg2;
+ I_ r;
+ FB_
+ MAYBE_GC(R2_PTR | R4_PTR, cmpIntegerIntzh_fast);
+ arg1._mp_size = R1.i;
+ arg1._mp_alloc= ((StgArrWords *)R2.p)->words;
+ arg1._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(R2.p));
+ arg2._mp_size = R3.i;
+ arg2._mp_alloc= ((StgArrWords *)R4.p)->words;
+ arg2._mp_d = (mp_limb_t *) (BYTE_ARR_CTS(R4.p));
+ r = RET_STGCALL2(I_,mpz_cmp,&arg1,&arg2);
+ RET_N(r);
+ FE_
+}
+
+FN_(integer2Intzh_fast)
+{
+ /* R1 = s; R2 = d */
+ I_ r, s;
+ FB_
+ s = R1.i;
+ if (s == 0)
+ r = 0;
+ else {
+ r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0];
+ if (s < 0) r = -r;
+ }
+ RET_N(r);
+ FE_
+}
+
+FN_(integer2Wordzh_fast)
+{
+ /* R1 = s; R2 = d */
+ I_ s;
+ W_ r;
+ FB_
+ s = R1.i;
+ if (s == 0)
+ r = 0;
+ else {
+ r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0];
+ if (s < 0) r = -r;
+ }
+ RET_N(r);
+ FE_
+}
+
+
FN_(decodeFloatzh_fast)
{
MP_INT mantissa;
*
* -------------------------------------------------------------------------- */
+FN_(isEmptyMVarzh_fast)
+{
+ /* args: R1 = MVar closure */
+ I_ r;
+ FB_
+ r = (I_)((GET_INFO((StgMVar*)(R1.p))) == &stg_EMPTY_MVAR_info);
+ RET_N(r);
+ FE_
+}
+
+
FN_(newMVarzh_fast)
{
StgMVar *mvar;
RET_P(sn_obj);
}
+
+FN_(makeStablePtrzh_fast)
+{
+ /* Args: R1 = a */
+ StgStablePtr sp;
+ FB_
+ MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
+ sp = RET_STGCALL1(StgStablePtr,getStablePtr,R1.p);
+ RET_N(sp);
+ FE_
+}
+
+FN_(deRefStablePtrzh_fast)
+{
+ /* Args: R1 = the stable ptr */
+ P_ r;
+ StgStablePtr sp;
+ FB_
+ sp = (StgStablePtr)R1.w;
+ ASSERT(stable_ptr_table[(StgWord)sp].weight > 0);
+ r = stable_ptr_table[(StgWord)sp].addr;
+ RET_P(r);
+ FE_
+}
+
/* -----------------------------------------------------------------------------
Bytecode object primitives
------------------------------------------------------------------------- */
projects / ghc-hetmet.git / commitdiff