import IO ( Handle )
+import PrimRep
import AbsCSyn
import ClosureInfo
import AbsCUtils ( getAmodeRep, nonemptyAbsC,
import DataCon ( dataConWrapId )
import Maybes ( 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,
addOneToUniqSet, UniqSet
)
-import StgSyn ( SRT(..), StgOp(..) )
+import StgSyn ( StgOp(..) )
import BitSet ( BitSet, intBS )
import Outputable
import GlaExts
-import Util ( nOfThem )
+import Util ( nOfThem, lengthExceeds, listLengthCmp )
+import Maybe ( isNothing, maybeToList )
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 (Just 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 Nothing (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 ?!?!"
+
+-- The rest generically.
+
+pprAbsC stmt@(CMachOpStmt (Just res) mop [arg1,arg2] maybe_vols) _
+ = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr, MO_NatS_MulMayOflo]
+ 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 (Just 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
-- should ignore and a (possibly void) result.
non_void_results =
let nvrs = grab_non_void_amodes results
- in ASSERT (length nvrs <= 1) nvrs
+ in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
pprAbsC (CCodeBlock lbl abs_C) _
= if not (maybeToBool(nonemptyAbsC abs_C)) then
}
-pprAbsC (CInitHdr cl_info amode cost_centre) _
+pprAbsC (CInitHdr cl_info amode cost_centre size) _
= hcat [ ptext SLIT("SET_HDR_"), char '(',
ppr_amode amode, comma,
pprCLabelAddr info_lbl, comma,
- if_profiling (pprAmode cost_centre),
+ if_profiling (pprAmode cost_centre), comma,
+ if_profiling (int size),
pp_paren_semi ]
where
info_lbl = infoTableLabelFromCI cl_info
-
+
pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
vcat [
is_constr = maybeToBool maybe_tag
(Just tag) = maybe_tag
- needs_srt = infoTblNeedsSRT cl_info
- srt = getSRTInfo cl_info
+ srt = closureSRT cl_info
+ needs_srt = case srt of
+ NoC_SRT -> False
+ other -> True
+
size = closureNonHdrSize cl_info
\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_MulMayOflo = text "mulIntMayOflo"
+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_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_8U_to_32U = text "(StgWord32)"
+pprMachOp_for_C MO_32U_to_8U = text "(StgWord8)"
+
+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 '*' <> text "sizeof(void*)")
+ 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)
\end{code}
\begin{code}
-pp_srt_info srt =
- case srt of
- (lbl, NoSRT) ->
- hcat [ int 0, comma,
- int 0, comma,
- int 0, comma ]
- (lbl, SRT off len) ->
- hcat [ pprCLabel lbl, comma,
- int off, comma,
- int len, comma ]
+pp_srt_info NoC_SRT = hcat [ int 0, comma,
+ int 0, comma,
+ int 0, comma ]
+pp_srt_info (C_SRT lbl off len) = hcat [ pprCLabel lbl, comma,
+ int off, comma,
+ int len, comma ]
\end{code}
\begin{code}
-- ---------------------------------------------------------------------------
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 [
non_void_results =
let nvrs = grab_non_void_amodes results
- in ASSERT (length nvrs <= 1) nvrs
+ in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
-- there will usually be two results: a (void) state which we
-- should ignore and a (possibly void) result.
in
case (read_int other) of
[(num,css)] ->
- if 0 <= num && num < length args
+ if num >= 0 && args `lengthExceeds` num
then parens (args !! num) <> process ress args css
else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
_ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
amode has kind2.
\begin{code}
+ppr_amode CBytesPerWord
+ = text "(sizeof(void*))"
+
+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}
ppr_decls_AbsC (CCodeBlock lbl absC)
= ppr_decls_AbsC absC
-ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
+ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre _)
-- ToDo: strictly speaking, should chk "cost_centre" amode
= labelSeenTE info_lbl `thenTE` \ label_seen ->
returnTE (Nothing,
where
info_lbl = infoTableLabelFromCI cl_info
+ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (maybeToList 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 ->
projects / ghc-hetmet.git / blobdiff