%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
module PprAbsC (
writeRealC,
- dumpRealC,
-#if defined(DEBUG)
- pprAmode, -- otherwise, not exported
+ dumpRealC
+#ifdef DEBUG
+ , pprAmode -- otherwise, not exported
#endif
-
- -- and for interface self-sufficiency...
- AbstractC, CAddrMode, MagicId,
- PprStyle, CSeq
) where
-IMPORT_Trace -- ToDo: rm (debugging only)
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo
+IMPORT_1_3(IO(Handle))
+IMPORT_1_3(Char(isDigit,isPrint))
+IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards
import AbsCSyn
-import PrelInfo ( pprPrimOp, primOpNeedsWrapper, PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
+import AbsCUtils ( getAmodeRep, nonemptyAbsC,
+ mixedPtrLocn, mixedTypeLocn
)
-import Literal ( literalPrimRep, showLiteral )
-import CLabel -- lots of things
import CgCompInfo ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
-import CgRetConv ( noLiveRegsMask )
-import ClosureInfo -- quite a few things
-import Costs -- for GrAnSim; cost counting function -- HWL
-import CostCentre
-import FiniteMap
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import Outputable
-import Pretty ( codeStyle, prettyToUn )
-import PrimRep ( showPrimRep, isFloatingRep, PrimRep(..) )
-import StgSyn
-import UniqFM
+import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
+ isReadOnly, needsCDecl, pprCLabel,
+ CLabel{-instance Ord-}
+ )
+import CmdLineOpts ( opt_SccProfilingOn )
+import CostCentre ( uppCostCentre, uppCostCentreDecl )
+import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
+import CStrings ( stringToC )
+import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
+import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
+import Literal ( showLiteral, Literal(..) )
+import Maybes ( maybeToBool, catMaybes )
+import PprStyle ( PprStyle(..) )
+import Pretty ( prettyToUn )
+import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
+import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) )
+import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
+ isConstantRep, isSpecRep, isPhantomRep
+ )
+import Unique ( pprUnique, Unique{-instance NamedThing-} )
+import UniqSet ( emptyUniqSet, elementOfUniqSet,
+ addOneToUniqSet, SYN_IE(UniqSet)
+ )
import Unpretty -- ********** NOTE **********
-import Util
+import Util ( nOfThem, panic, assertPanic )
infixr 9 `thenTE`
\end{code}
@pprAbsC@ has a new ``costs'' argument. %% HWL
\begin{code}
-writeRealC :: _FILE -> AbstractC -> PrimIO ()
+writeRealC :: Handle -> AbstractC -> IO ()
-writeRealC sw_chker file absC
- = uppAppendFile file 80 (
- uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n')
+writeRealC handle absC
+ = uppPutStr handle 80 (
+ uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
)
dumpRealC :: AbstractC -> String
-dumpRealC sw_chker absC
+dumpRealC absC
= uppShow 80 (
- uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n')
+ uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
)
\end{code}
\begin{code}
emitMacro :: CostRes -> Unpretty
-#ifndef GRAN
-emitMacro _ = uppNil
-#else
+-- ToDo: Check a compile time flag to decide whether a macro should be emitted
emitMacro (Cost (i,b,l,s,f))
= uppBesides [ uppStr "GRAN_EXEC(",
- uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma,
- uppInt s, uppComma, uppInt f, pp_paren_semi ]
-#endif {-GRAN-}
+ uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma,
+ uppInt s, uppComma, uppInt f, pp_paren_semi ]
\end{code}
\begin{code}
the_op = ppr_op_call non_void_results non_void_args
-- liveness mask is *in* the non_void_args
in
- BIND (ppr_vol_regs sty vol_regs) _TO_ (pp_saves, pp_restores) ->
+ case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) ->
if primOpNeedsWrapper op then
uppAboves [ pp_saves,
the_op,
]
else
the_op
- BEND
+ }
where
ppr_op_call results args
= uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen,
pprAbsC sty (CCodeBlock label abs_C) _
= ASSERT( maybeToBool(nonemptyAbsC abs_C) )
- BIND (pprTempAndExternDecls abs_C) _TO_ (pp_temps, pp_exts) ->
+ case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
uppAboves [
uppBesides [uppStr (if (externallyVisibleCLabel label)
then "FN_(" -- abbreviations to save on output
else "IFN_("),
pprCLabel sty label, uppStr ") {"],
case sty of
- PprForC _ -> uppAbove pp_exts pp_temps
+ PprForC -> uppAbove pp_exts pp_temps
_ -> uppNil,
uppNest 8 (uppPStr SLIT("FB_")),
uppNest 8 (pprAbsC sty abs_C (costs abs_C)),
uppNest 8 (uppPStr SLIT("FE_")),
uppChar '}' ]
- BEND
+ }
pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
= uppBesides [ pp_init_hdr, uppStr "_HDR(",
getSMInitHdrStr sm_rep)
pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
- = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) ->
+ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
uppAboves [
case sty of
- PprForC _ -> pp_exts
+ PprForC -> pp_exts
_ -> uppNil,
uppBesides [
uppStr "SET_STATIC_HDR(",
uppNest 2 (uppBesides (map (ppr_item sty) amodes)),
uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)),
uppStr "};" ]
- BEND
+ }
where
info_lbl = infoTableLabelFromCI cl_info
if not (closureUpdReqd cl_info) then
[]
else
- BIND (max 0 (mIN_UPD_SIZE - length amodes)) _TO_ still_needed ->
- nOfThem still_needed (mkIntCLit 0) -- a bunch of 0s
- BEND
+ case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
+ nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
{-
STATIC_INIT_HDR(c,i,localness) blows into:
pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static")
pprAbsC sty stmt@(CFlatRetVector label amodes) _
- = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) ->
+ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
uppAboves [
case sty of
- PprForC _ -> pp_exts
+ PprForC -> pp_exts
_ -> uppNil,
uppBesides [ppLocalness label, uppPStr SLIT(" W_ "),
pprCLabel sty label, uppStr "[] = {"],
uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)),
- uppStr "};" ]
- BEND
+ uppStr "};" ] }
where
ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const")
ppLocalnessMacro for_fun{-vs data-} clabel
- = BIND (if externallyVisibleCLabel clabel then "E" else "I") _TO_ prefix ->
- BIND (if isReadOnly clabel then "RO_" else "") _TO_ suffix ->
+ = case (if externallyVisibleCLabel clabel then "E" else "I") of { prefix ->
+ case (if isReadOnly clabel then "RO_" else "") of { suffix ->
if for_fun
then uppStr (prefix ++ "F_")
else uppStr (prefix ++ "D_" ++ suffix)
- BEND BEND
+ } }
\end{code}
\begin{code}
\begin{code}
if_profiling sty pretty
= case sty of
- PprForC sw_chker -> if sw_chker SccProfilingOn
- then pretty
- else uppChar '0' -- leave it out!
+ PprForC -> if opt_SccProfilingOn
+ then pretty
+ else uppChar '0' -- leave it out!
_ -> {-print it anyway-} pretty
(This happens after restoration of essential registers because we
might need the @Base@ register to access all the others correctly.)
+{- Doesn't apply anymore with ForeignObj, structure create via primop.
+ makeForeignObj (ForeignObj is not CReturnable)
7) If returning Malloc Pointer, build a closure containing the
appropriate value.
-
+-}
Otherwise, copy local variable into result register.
8) If ccall (not casm), declare the function being called as extern so
basic_restores;
restores;
- #if MallocPtr
- constructMallocPtr(liveness, return_reg, _ccall_result);
- #else
- return_reg = _ccall_result;
- #end
+ return_reg = _ccall_result;
}
\end{pseudocode}
can get at them.
* be sure that there are no live registers or we're in trouble.
(This can cause problems if you try something foolish like passing
- an array or mallocptr to a _ccall_GC_ thing.)
+ an array or foreign obj to a _ccall_GC_ thing.)
* increment/decrement the @inCCallGC@ counter before/after the call so
that the runtime check that PerformGC is being used sensibly will work.
= if (may_gc && liveness_mask /= noLiveRegsMask)
then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat pp_non_void_args)) ++ "\n")
else
--- trace ("casm \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat localVars)) ++ (uppShow 80 (uppCat pp_non_void_args)))
uppAboves [
uppChar '{',
declare_local_vars, -- local var for *result*
If the argument is a heap object, we need to reach inside and pull out
the bit the C world wants to see. The only heap objects which can be
-passed are @Array@s, @ByteArray@s and @MallocPtr@s.
+passed are @Array@s, @ByteArray@s and @ForeignObj@s.
\begin{code}
ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty)
ByteArrayRep -> (pp_kind,
uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen])
- -- for Malloc Pointers, use MALLOC_PTR_DATA to fish out the contents.
- MallocPtrRep -> (uppPStr SLIT("StgMallocPtr"),
- uppBesides [uppStr "MallocPtr_CLOSURE_DATA(", pp_amode, uppStr")"])
+ -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
+ ForeignObjRep -> (uppPStr SLIT("StgForeignObj"),
+ uppBesides [uppStr "ForeignObj_CLOSURE_DATA(", pp_amode, uppStr")"])
other -> (pp_kind, pp_amode)
declare_local_var
We only allow zero or one results.
-2) Is the result is a mallocptr?
+{- With the introduction of ForeignObj (MallocPtr++), no longer necess.
+2) Is the result is a foreign obj?
The mallocptr must be encapsulated immediately in a heap object.
-
+-}
\begin{code}
ppr_casm_results ::
PprStyle -- style
(result_type, assign_result)
= case r_kind of
- MallocPtrRep ->
- (uppPStr SLIT("StgMallocPtr"),
- uppBesides [ uppStr "constructMallocPtr(",
+{- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
+ Instead, external references have to be turned into ForeignObjs
+ using the primop makeForeignObj#. Benefit: Multiple finalisation
+ routines can be accommodated and the below special case is not needed.
+ Price is, of course, that you have to explicitly wrap `foreign objects'
+ with makeForeignObj#.
++
+ ForeignObjRep ->
+ (uppPStr SLIT("StgForeignObj"),
+ uppBesides [ uppStr "constructForeignObj(",
liveness, uppComma,
result_reg, uppComma,
local_var,
- pp_paren_semi ])
+ pp_paren_semi ]) -}
_ ->
(pprPrimKind sty r_kind,
uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
_ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n")
other ->
- case readDec other of
+ let
+ read_int :: ReadS Int
+ read_int = reads
+ in
+ case (read_int other) of
[(num,css)] ->
if 0 <= num && num < length args
- then uppBesides [uppLparen, args !! num, uppRparen,
- process ress args css]
+ then uppBeside (uppParens (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")
pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty
pprAssign sty VoidRep dest src = uppNil
-
-#if 0
-pprAssign sty kind dest src
- | (kind /= getAmodeRep dest) || (kind /= getAmodeRep src)
- = uppCat [uppStr "Bad kind:", pprPrimKind sty kind,
- pprPrimKind sty (getAmodeRep dest), pprAmode sty dest,
- pprPrimKind sty (getAmodeRep src), pprAmode sty src]
-#endif
\end{code}
Special treatment for floats and doubles, to avoid unwanted conversions.
\begin{code}
pprAmode sty amode
| mixedTypeLocn amode
- = uppBesides [ uppLparen, pprPrimKind sty (getAmodeRep amode), uppStr ")(",
- ppr_amode sty amode, uppRparen]
+ = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppStr ")(",
+ ppr_amode sty amode ])
| otherwise -- No cast needed
= ppr_amode sty amode
\end{code}
ppr_amode sty (CVal reg_rel _)
= case (pprRegRelative sty False{-no sign wanted-} reg_rel) of
(pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg
- (pp_reg, Just offset) -> uppBesides [ pp_reg, uppLbrack, offset, uppRbrack ]
+ (pp_reg, Just offset) -> uppBesides [ pp_reg, uppBracket offset ]
ppr_amode sty (CAddr reg_rel)
= case (pprRegRelative sty True{-sign wanted-} reg_rel) of
pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
pprUnionTag StablePtrRep = uppChar 'i'
-pprUnionTag MallocPtrRep = uppChar 'p'
+pprUnionTag ForeignObjRep = uppChar 'p'
pprUnionTag ArrayRep = uppChar 'p'
pprUnionTag ByteArrayRep = uppChar 'b'
pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
= initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
- BIND (catMaybes [t_p1, t_p2]) _TO_ real_temps ->
- BIND (catMaybes [e_p1, e_p2]) _TO_ real_exts ->
- returnTE (uppAboves real_temps, uppAboves real_exts)
- BEND BEND
+ case (catMaybes [t_p1, t_p2]) of { real_temps ->
+ case (catMaybes [e_p1, e_p2]) of { real_exts ->
+ returnTE (uppAboves real_temps, uppAboves real_exts) }}
)
pprTempAndExternDecls other_stmt
= case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
addToCLabelSet set x = addToFM set x ()
-type UniqueSet = UniqFM ()
-emptyUniqueSet = emptyUFM
-x `elementOfUniqueSet` us
- = case (lookupDirectlyUFM us x) of { Just _ -> True; Nothing -> False }
-addToUniqueSet set x = set `plusUFM` singletonDirectlyUFM x ()
-
-type TEenv = (UniqueSet, CLabelSet)
+type TEenv = (UniqSet Unique, CLabelSet)
type TeM result = TEenv -> (TEenv, result)
initTE :: TeM a -> a
initTE sa
- = case sa (emptyUniqueSet, emptyCLabelSet) of { (_, result) ->
+ = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) ->
result }
{-# INLINE thenTE #-}
tempSeenTE :: Unique -> TeM Bool
tempSeenTE uniq env@(seen_uniqs, seen_labels)
- = if (uniq `elementOfUniqueSet` seen_uniqs)
+ = if (uniq `elementOfUniqSet` seen_uniqs)
then (env, True)
- else ((addToUniqueSet seen_uniqs uniq,
+ else ((addOneToUniqSet seen_uniqs uniq,
seen_labels),
False)
pprTempDecl uniq kind
= uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ]
-ppr_for_C = PprForC ( \ x -> False ) -- pretend no special cmd-line flags
-
pprExternDecl :: CLabel -> PrimRep -> Unpretty
pprExternDecl clabel kind
= if not (needsCDecl clabel) then
uppNil -- do not print anything for "known external" things (e.g., < PreludeCore)
else
- BIND (
+ case (
case kind of
CodePtrRep -> ppLocalnessMacro True{-function-} clabel
- _ -> ppLocalnessMacro False{-data-} clabel
- ) _TO_ pp_macro_str ->
+ _ -> ppLocalnessMacro False{-data-} clabel
+ ) of { pp_macro_str ->
- uppBesides [ pp_macro_str, uppLparen, pprCLabel ppr_for_C clabel, pp_paren_semi ]
- BEND
+ uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ]
+ }
\end{code}
\begin{code}
maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty)
maybe_uppAboves ps
- = BIND (unzip ps) _TO_ (ts, es) ->
- BIND (catMaybes ts) _TO_ real_ts ->
- BIND (catMaybes es) _TO_ real_es ->
+ = case (unzip ps) of { (ts, es) ->
+ case (catMaybes ts) of { real_ts ->
+ case (catMaybes es) of { real_es ->
(if (null real_ts) then Nothing else Just (uppAboves real_ts),
if (null real_es) then Nothing else Just (uppAboves real_es))
- BEND BEND BEND
+ } } }
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff