import IO ( Handle )
+import PrimRep
import AbsCSyn
import ClosureInfo
import AbsCUtils ( getAmodeRep, nonemptyAbsC,
mixedPtrLocn, mixedTypeLocn
)
-import Constants ( mIN_UPD_SIZE )
-import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute )
+import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
+ playThreadSafe, ccallConvAttribute )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
import DataCon ( dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper )
+import MachOp ( MachOp(..) )
import ForeignCall ( ForeignCall(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
import SMRep ( pprSMRep )
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 ( lengthExceeds, listLengthCmp )
import ST
-- primop macros do their own casting of result;
-- hence we can toss the provided cast...
+-- NEW CASES FOR EXPANDED PRIMOPS
+
+pprAbsC stmt@(CMachOpStmt 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 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) _
+
+pprAbsC stmt@(CStaticClosure cl_info cost_centre amodes) _
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
vcat [
pp_exts,
ppLocalnessMacro True{-include dyn-} info_lbl,
char ')'
],
- nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)),
+ nest 2 (ppr_payload amodes),
ptext SLIT("};") ]
}
where
- info_lbl = infoTableLabelFromCI cl_info
+ closure_lbl = closureLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info
ppr_payload [] = empty
- ppr_payload ls = comma <+>
- braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls)))
-
- ppr_item item
- | rep == VoidRep = text "0" -- might not even need this...
- | rep == FloatRep = ppr_amode (floatToWord item)
- | rep == DoubleRep = hcat (punctuate (text ", (L_)")
- (map ppr_amode (doubleToWords item)))
- | otherwise = ppr_amode item
+ ppr_payload ls =
+ comma <+>
+ (braces $ hsep $ punctuate comma $
+ map (text "(L_)" <>) (foldr ppr_item [] ls))
+
+ ppr_item item rest
+ | rep == VoidRep = rest
+ | rep == FloatRep = ppr_amode (floatToWord item) : rest
+ | rep == DoubleRep = map ppr_amode (doubleToWords item) ++ rest
+ | otherwise = ppr_amode item : rest
where
- rep = getAmodeRep item
-
- upd_reqd = closureUpdReqd cl_info
+ rep = getAmodeRep item
- padding_wds
- | not upd_reqd = []
- | otherwise = case max 0 (mIN_UPD_SIZE - length amodes) of { still_needed ->
- nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
-
- -- always have a static link field, it's used to save the closure's
- -- info pointer when we're reverting CAFs (see comment in Storage.c)
- static_link_field
- | upd_reqd || staticClosureNeedsLink cl_info = [mkIntCLit 0]
- | otherwise = []
pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
= 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)"
+
+
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 [
]
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
+
+ thread_macro_args = ppr_uniq_token <> comma <+>
+ text "rts" <> ppr (playThreadSafe safety)
+ ppr_uniq_token = text "tok_" <> ppr uniq
(pp_save_context, pp_restore_context)
- | playSafe safety = ( text "{ I_ id; SUSPEND_THREAD(id);"
- , text "RESUME_THREAD(id);}"
+ | playSafe safety = ( text "{ I_" <+> ppr_uniq_token <>
+ text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi
+ , text "RESUME_THREAD" <> parens thread_macro_args <> text ";}"
)
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
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")
\begin{code}
pprAssign FloatRep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = hcat [ ptext SLIT("ASSIGN_FLT((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
pprAssign DoubleRep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = hcat [ ptext SLIT("ASSIGN_DBL((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
pprAssign Int64Rep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_Int64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = hcat [ ptext SLIT("ASSIGN_Int64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
pprAssign Word64Rep dest@(CVal reg_rel _) src
- = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ]
+ = hcat [ ptext SLIT("ASSIGN_Word64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ]
\end{code}
Lastly, the question is: will the C compiler think the types of the
\begin{code}
pprAmode (CVal reg_rel FloatRep)
- = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_FLT((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel DoubleRep)
- = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_DBL((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel Int64Rep)
- = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_Int64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
pprAmode (CVal reg_rel Word64Rep)
- = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ]
+ = hcat [ text "PK_Word64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ]
\end{code}
Next comes the case where there is some other cast need, and the
amode has kind2.
\begin{code}
+ppr_amode CBytesPerWord
+ = text "(sizeof(void*))"
+
ppr_amode (CVal reg_rel@(CIndex _ _ _) kind)
= case (pprRegRelative False{-no sign wanted-} reg_rel) of
(pp_reg, Nothing) -> panic "ppr_amode: CIndex"
cStmtMacroText PUSH_SEQ_FRAME = SLIT("PUSH_SEQ_FRAME")
cStmtMacroText UPDATE_SU_FROM_UPD_FRAME = SLIT("UPDATE_SU_FROM_UPD_FRAME")
cStmtMacroText SET_TAG = SLIT("SET_TAG")
+cStmtMacroText DATA_TO_TAGZH = SLIT("dataToTagzh")
cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
cStmtMacroText REGISTER_IMPORT = SLIT("REGISTER_IMPORT")
cStmtMacroText REGISTER_DIMPORT = SLIT("REGISTER_DIMPORT")
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 (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 ->
-- no real reason to, anyway.
ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes
-ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
+ppr_decls_AbsC (CStaticClosure closure_info cost_centre amodes)
-- ToDo: strictly speaking, should chk "cost_centre" amode
= ppr_decls_Amodes amodes
projects / ghc-hetmet.git / blobdiff