%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
-\section[AbsCFuns]{Help functions for Abstract~C datatype}
+\section[AbsCUtils]{Help functions for Abstract~C datatype}
\begin{code}
#include "HsVersions.h"
-module AbsCFuns (
+module AbsCUtils (
nonemptyAbsC,
mkAbstractCs, mkAbsCStmts,
mkAlgAltsCSwitch,
kindFromMagicId,
- getAmodeKind, amodeCanSurviveGC,
+ getAmodeRep, amodeCanSurviveGC,
mixedTypeLocn, mixedPtrLocn,
flattenAbsC,
---UNUSED: getDestinationRegs,
- mkAbsCStmtList,
+ mkAbsCStmtList
-- printing/forcing stuff comes from PprAbsC
-- and for interface self-sufficiency...
- AbstractC, CAddrMode, PrimKind, SplitUniqSupply
) where
import AbsCSyn
-import AbsPrel ( PrimOp(..)
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( kindFromType, splitTyArgs, TauType(..),
- TyVar, TyCon, Arity(..), Class, UniType
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-
-#ifndef DPH
-import CLabelInfo ( CLabel, mkReturnPtLabel, mkVecTblLabel )
-#else
-import CLabelInfo ( CLabel, mkReturnPtLabel,
- isNestableBlockLabel, isSlowFastLabelPair )
-#endif {- Data Parallel Haskell -}
-
-import BasicLit ( kindOfBasicLit )
+import Literal ( literalPrimRep )
+import CLabel ( CLabel, mkReturnPtLabel, mkVecTblLabel )
import Digraph ( stronglyConnComp )
import Id ( fIRST_TAG, ConTag(..), DataCon(..), Id )
import Maybes ( Maybe(..) )
-import PrimKind ( getKindSize, retKindSize, PrimKind(..) )
-import SplitUniq
-import StgSyn ( StgAtom )
-import Unique -- UniqueSupply primitives used in flattening monad
-import Util
+import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) )
+import UniqSupply
+import StgSyn ( GenStgArg )
infixr 9 `thenFlt`
\end{code}
\begin{code}
nonemptyAbsC :: AbstractC -> Maybe AbstractC
nonemptyAbsC AbsCNop = Nothing
---UNUSED:nonemptyAbsC (CComment _) = Nothing
nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
Nothing -> nonemptyAbsC s2
Just x -> Just (AbsCStmts x s2)
Get the sho' 'nuff statements out of an @AbstractC@.
\begin{code}
-{-
mkAbsCStmtList :: AbstractC -> [AbstractC]
-mkAbsCStmtList AbsCNop = []
---UNUSED:mkAbsCStmtList (CComment _) = []
-mkAbsCStmtList (AbsCStmts s1 s2) = mkAbsCStmtList s1 ++ mkAbsCStmtList s2
-mkAbsCStmtList s@(CSimultaneous c) = if null (mkAbsCStmtList c)
- then []
- else [s]
-mkAbsCStmtList other = [other]
--}
+mkAbsCStmtList absC = mkAbsCStmtList' absC []
-mkAbsCStmtList :: AbstractC -> [AbstractC]
-mkAbsCStmtList absC = mkAbsCStmtList' absC []
-
-- Optimised a la foldr/build!
-mkAbsCStmtList' AbsCNop r = r
---UNUSED:mkAbsCStmtList' (CComment _) r = r
-mkAbsCStmtList' (AbsCStmts s1 s2) r =
- mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
-mkAbsCStmtList' s@(CSimultaneous c) r =
- if null (mkAbsCStmtList c) then r else s : r
-mkAbsCStmtList' other r = other : r
+mkAbsCStmtList' AbsCNop r = r
+
+mkAbsCStmtList' (AbsCStmts s1 s2) r
+ = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
+
+mkAbsCStmtList' s@(CSimultaneous c) r
+ = if null (mkAbsCStmtList c) then r else s : r
+mkAbsCStmtList' other r = other : r
\end{code}
\begin{code}
-- data types. Why? Because for two-constructor types, zero is faster
-- to create and distinguish from 1 than are 1 and 2.
- -- We also need to convert to BasicLits to keep the CSwitch happy
+ -- We also need to convert to Literals to keep the CSwitch happy
adjust tagged_alts
= [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
| (tag, abs_c) <- tagged_alts ]
%************************************************************************
%* *
-\subsubsection[AbsCFuns-kinds-from-MagicIds]{Kinds from MagicIds}
+\subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
%* *
%************************************************************************
\begin{code}
-kindFromMagicId BaseReg = PtrKind
-kindFromMagicId StkOReg = PtrKind
+kindFromMagicId BaseReg = PtrRep
+kindFromMagicId StkOReg = PtrRep
kindFromMagicId (VanillaReg kind _) = kind
-kindFromMagicId (FloatReg _) = FloatKind
-kindFromMagicId (DoubleReg _) = DoubleKind
-kindFromMagicId TagReg = IntKind
-kindFromMagicId RetReg = RetKind
-kindFromMagicId SpA = PtrKind
-kindFromMagicId SuA = PtrKind
-kindFromMagicId SpB = PtrKind
-kindFromMagicId SuB = PtrKind
-kindFromMagicId Hp = PtrKind
-kindFromMagicId HpLim = PtrKind
-kindFromMagicId LivenessReg = IntKind
---kindFromMagicId ActivityReg = IntKind -- UNUSED
-kindFromMagicId StdUpdRetVecReg = PtrKind
-kindFromMagicId StkStubReg = PtrKind
-kindFromMagicId CurCostCentre = CostCentreKind
-kindFromMagicId VoidReg = VoidKind
-#ifdef DPH
-kindFromMagicId (DataReg _ n) = kind
-#endif {- Data Parallel Haskell -}
+kindFromMagicId (FloatReg _) = FloatRep
+kindFromMagicId (DoubleReg _) = DoubleRep
+kindFromMagicId TagReg = IntRep
+kindFromMagicId RetReg = RetRep
+kindFromMagicId SpA = PtrRep
+kindFromMagicId SuA = PtrRep
+kindFromMagicId SpB = PtrRep
+kindFromMagicId SuB = PtrRep
+kindFromMagicId Hp = PtrRep
+kindFromMagicId HpLim = PtrRep
+kindFromMagicId LivenessReg = IntRep
+kindFromMagicId StdUpdRetVecReg = PtrRep
+kindFromMagicId StkStubReg = PtrRep
+kindFromMagicId CurCostCentre = CostCentreRep
+kindFromMagicId VoidReg = VoidRep
\end{code}
%************************************************************************
%* *
-\subsection[AbsCFuns-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
+\subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
%* *
%************************************************************************
ToDo: tiny tweaking may be in order
\begin{code}
-getAmodeKind :: CAddrMode -> PrimKind
-
-getAmodeKind (CVal _ kind) = kind
-getAmodeKind (CAddr _) = PtrKind
-getAmodeKind (CReg magic_id) = kindFromMagicId magic_id
-getAmodeKind (CTemp uniq kind) = kind
-getAmodeKind (CLbl label kind) = kind
-getAmodeKind (CUnVecLbl _ _) = PtrKind
-getAmodeKind (CCharLike _) = PtrKind
-getAmodeKind (CIntLike _) = PtrKind
-getAmodeKind (CString _) = PtrKind
-getAmodeKind (CLit lit) = kindOfBasicLit lit
-getAmodeKind (CLitLit _ kind) = kind
-getAmodeKind (COffset _) = IntKind
-getAmodeKind (CCode abs_C) = CodePtrKind
-getAmodeKind (CLabelledCode label abs_C) = CodePtrKind
-getAmodeKind (CJoinPoint _ _) = panic "getAmodeKind:CJoinPoint"
-getAmodeKind (CTableEntry _ _ kind) = kind
-getAmodeKind (CMacroExpr kind _ _) = kind
-getAmodeKind (CCostCentre _ _) = panic "getAmodeKind:CCostCentre"
+getAmodeRep :: CAddrMode -> PrimRep
+
+getAmodeRep (CVal _ kind) = kind
+getAmodeRep (CAddr _) = PtrRep
+getAmodeRep (CReg magic_id) = kindFromMagicId magic_id
+getAmodeRep (CTemp uniq kind) = kind
+getAmodeRep (CLbl label kind) = kind
+getAmodeRep (CUnVecLbl _ _) = PtrRep
+getAmodeRep (CCharLike _) = PtrRep
+getAmodeRep (CIntLike _) = PtrRep
+getAmodeRep (CString _) = PtrRep
+getAmodeRep (CLit lit) = literalPrimRep lit
+getAmodeRep (CLitLit _ kind) = kind
+getAmodeRep (COffset _) = IntRep
+getAmodeRep (CCode abs_C) = CodePtrRep
+getAmodeRep (CLabelledCode label abs_C) = CodePtrRep
+getAmodeRep (CTableEntry _ _ kind) = kind
+getAmodeRep (CMacroExpr kind _ _) = kind
+#ifdef DEBUG
+getAmodeRep (CJoinPoint _ _) = panic "getAmodeRep:CJoinPoint"
+getAmodeRep (CCostCentre _ _) = panic "getAmodeRep:CCostCentre"
+#endif
\end{code}
@amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
%************************************************************************
%* *
-\subsection[AbsCFuns-flattening]{Flatten Abstract~C}
+\subsection[AbsCUtils-flattening]{Flatten Abstract~C}
%* *
%************************************************************************
nesting, and flattens it into one long @AbsCStmtList@. Mainly,
@CClosureInfos@ and code for switches are pulled out to the top level.
-The various functions herein tend to produce
+The various functions herein tend to produce
\begin{enumerate}
\item
-A {\em flattened} \tr{<something>} of interest for ``here'', and
+A {\em flattened} \tr{<something>} of interest for ``here'', and
\item
Some {\em unflattened} Abstract~C statements to be carried up to the
top-level. The only real reason (now) that it is unflattened is
flattened, the ``tops'' stuff is a @CCodeBlock@.
\begin{code}
-flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
+flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
flattenAbsC us abs_C
= case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
\begin{code}
type FlatM result
= CLabel
- -> SplitUniqSupply
+ -> UniqSupply
-> result
-initFlt :: SplitUniqSupply -> FlatM a -> a
+initFlt :: UniqSupply -> FlatM a -> a
initFlt init_us m = m (panic "initFlt:CLabel") init_us
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenFlt #-}
{-# INLINE returnFlt #-}
-#endif
thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
returnFlt (r1:rs1, r2:rs2)
getUniqFlt :: FlatM Unique
-getUniqFlt label us = getSUnique us
+getUniqFlt label us = getUnique us
getUniqsFlt :: Int -> FlatM [Unique]
-getUniqsFlt i label us = getSUniques i us
+getUniqsFlt i label us = getUniques i us
setLabelFlt :: CLabel -> FlatM a -> FlatM a
setLabelFlt new_label cont label us = cont new_label us
flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
= flatAmodes (cost_centre:amodes) `thenFlt` \ (new_cc:new_amodes, tops) ->
- returnFlt (AbsCNop, tops `mkAbsCStmts`
- CStaticClosure closure_lbl closure_info new_cc new_amodes)
+ returnFlt (AbsCNop, tops `mkAbsCStmts`
+ CStaticClosure closure_lbl closure_info new_cc new_amodes)
flatAbsC (CRetVector tbl_label stuff deflt)
= do_deflt deflt `thenFlt` \ (deflt_amode, deflt_tops) ->
mapAndUnzipFlt (do_alt deflt_amode) stuff `thenFlt` \ (alt_amodes, alt_tops) ->
- returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
- mkAbstractCs alt_tops,
+ returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
+ mkAbstractCs alt_tops,
CFlatRetVector tbl_label alt_amodes])
where
do_deflt deflt = case nonemptyAbsC deflt of
Nothing -> returnFlt (bogus_default_label, AbsCNop)
- Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
+ Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
-- CJump (CLabelledCode ...) case
do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop)
= flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
returnFlt (CCallProfCCMacro str amodes_here, tops)
---UNUSED:flatAbsC comment_stmt@(CComment comment) = returnFlt (AbsCNop, AbsCNop)
-
flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
-
-#ifdef DPH
- -- Hack since 0.16 because Direct entry code blocks can be nested
- -- within other Direct entry blocks...
- flatAbsC (CNativeInfoTableAndCode cinfo descr
- (CCodeBlock slow_label
- (AbsCStmts slow_abs_c
- (CCodeBlock fast_label fast_abs_c))))
- | isSlowFastLabelPair slow_label fast_label
- = flatAbsC slow_abs_c `thenFlt` \ (slow_here, slow_top) ->
- flatAbsC fast_abs_c `thenFlt` \ (fast_here, fast_top) ->
- returnFlt (CNativeInfoTableAndCode cinfo descr
- (CCodeBlock slow_label
- (AbsCStmts slow_here
- (CCodeBlock fast_label fast_here))),
- mkAbsCStmts slow_top fast_top)
-
- flatAbsC (CNativeInfoTableAndCode cinfo descr abs_C)
- = flatAbsC abs_C `thenFlt` \ (heres, tops) ->
- returnFlt (CNativeInfoTableAndCode cinfo descr heres, tops)
-#endif {- Data Parallel Haskell -}
-
---flatAbsC stmt = panic ("flatAbsC: funny statement " ++ printRealC (\x->False) stmt)
\end{code}
%************************************************************************
flatAmode (CLabelledCode label abs_C)
-- Push the code (with this label) to the top level
= flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
- returnFlt (CLbl label CodePtrKind,
+ returnFlt (CLbl label CodePtrRep,
tops `mkAbsCStmts` CCodeBlock label body_code)
flatAmode (CCode abs_C)
[CJump amode] -> flatAmode amode -- Elide redundant labels
_ ->
-- de-anonymous-ise the code and push it (labelled) to the top level
- getUniqFlt `thenFlt` \ new_uniq ->
+ getUniqFlt `thenFlt` \ new_uniq ->
BIND (mkReturnPtLabel new_uniq) _TO_ return_pt_label ->
flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
returnFlt (
- CLbl return_pt_label CodePtrKind,
+ CLbl return_pt_label CodePtrRep,
tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
-- DO NOT TOUCH the stuff sent to the top...
)
BEND
-
+
flatAmode (CTableEntry base index kind)
= flatAmode base `thenFlt` \ (base_amode, base_tops) ->
flatAmode index `thenFlt` \ (ix_amode, ix_tops) ->
We use the strongly-connected component algorithm, in which
* the vertices are the statements
- * an edge goes from s1 to s2 iff
+ * an edge goes from s1 to s2 iff
s1 assigns to something s2 uses
that is, if s1 should *follow* s2 in the final order
go_via_temps (CAssign dest src)
= getUniqFlt `thenFlt` \ uniq ->
- let the_temp = CTemp uniq (getAmodeKind dest) in
+ let
+ the_temp = CTemp uniq (getAmodeRep dest)
+ in
returnFlt (CAssign the_temp src, CAssign dest the_temp)
go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
= getUniqsFlt (length dests) `thenFlt` \ uniqs ->
- let the_temps = zipWith (\ u d -> CTemp u (getAmodeKind d)) uniqs dests
+ let
+ the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
in
returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
mkAbstractCs (zipWith CAssign dests the_temps))
(CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
(CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
(CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
- = rrConflictsWithRR (getKindSize k1) (getKindSize k2) reg_rel1 reg_rel2
+ = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
other1 `conflictsWith` other2 = False
-- CAddr and literals are impossible on the LHS of an assignment
rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
where
- rr (SpARel p1 o1) (SpARel p2 o2)
+ rr (SpARel p1 o1) (SpARel p2 o2)
| s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
| s1 == 1 && s2 == 1 = b1 == b2
| otherwise = (b1+s1) >= b2 &&
rr other1 other2 = False
\end{code}
-
-%************************************************************************
-%* *
-\subsection[gaze-into-simultaneous]{Registers live in a @CSimultaneous@?}
-%* *
-%************************************************************************
-
-Hidden in a blob of ``simultaneous assignments'' is the info of how
-many pointer (``followable'') registers are live (i.e., assigned
-into). What we do here is merely fish out the destination registers.
-
-\begin{code}
-{- UNUSED:
-getDestinationRegs :: AbstractC -> [MagicId]
-
-getDestinationRegs abs_c
- = foldr gather [{-acc-}] (en_list abs_c)
- where
- gather :: AbstractC -> [MagicId] -> [MagicId]
-
- -- only CAssigns and COpStmts now possible...
-
- gather (CAssign (CReg magic_id) _) acc | magic_id `not_elem` acc
- = magic_id : acc
- where
- not_elem = isn'tIn "getDestinationRegs"
-
- gather (COpStmt dests _ _ _ _) acc
- = foldr gather2 acc dests
- where
- gather2 (CReg magic_id) acc | magic_id `not_elem` acc = magic_id : acc
- gather2 _ acc = acc
-
- not_elem = isn'tIn "getDestinationRegs2"
-
- gather _ acc = acc
--}
-\end{code}
projects / ghc-hetmet.git / blobdiff