module PprAbsC (
writeRealC,
dumpRealC
-#if defined(DEBUG)
+#ifdef DEBUG
, pprAmode -- otherwise, not exported
#endif
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- break its dependence on ClosureInfo
+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 CostCentre ( uppCostCentre, uppCostCentreDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
import CStrings ( stringToC )
-import FiniteMap ( addToFM, emptyFM, lookupFM )
+import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
import HeapOffs ( isZeroOff, subOff, pprHeapOffset )
import Literal ( showLiteral, Literal(..) )
import Maybes ( maybeToBool, catMaybes )
)
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
- addOneToUniqSet, UniqSet(..)
+ addOneToUniqSet, SYN_IE(UniqSet)
)
import Unpretty -- ********** NOTE **********
import Util ( nOfThem, panic, assertPanic )
@pprAbsC@ has a new ``costs'' argument. %% HWL
\begin{code}
-writeRealC :: _FILE -> AbstractC -> IO ()
+writeRealC :: Handle -> AbstractC -> IO ()
-writeRealC file absC
- = uppAppendFile file 80 (
+writeRealC handle absC
+ = uppPutStr handle 80 (
uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
)
\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
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
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
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}
(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 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 uppBeside (uppParens (args !! num))
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.
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
= 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 PprForC clabel, pp_paren_semi ]
- BEND
+ }
\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