[project @ 1996-01-08 20:28:12 by partain]

Initial revision

1 files changed, 264 insertions, 0 deletions

diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
new file mode 100644
index 0000000000..3ec30f02ea
--- /dev/null
+++ b/ghc/compiler/codeGen/CgStackery.lhs
@@ -0,0 +1,264 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[CgStackery]{Stack management functions}
+
+Stack-twiddling operations, which are pretty low-down and grimy.
+(This is the module that knows all about stack layouts, etc.)
+
+\begin{code}
+#include "HsVersions.h"
+
+module CgStackery (
+	allocAStack, allocBStack, allocUpdateFrame,
+	adjustRealSps, getFinalStackHW,
+	mkVirtStkOffsets, mkStkAmodes,
+
+	-- and to make the interface self-sufficient...
+	AbstractC, CAddrMode, CgState, PrimKind
+    ) where
+
+import StgSyn
+import CgMonad
+import AbsCSyn
+
+import CgUsages		( getSpBRelOffset )
+import Maybes		( Maybe(..) )
+import PrimKind		( getKindSize, retKindSize, separateByPtrFollowness )
+import Util
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[CgStackery-layout]{Laying out a stack frame}
+%*									*
+%************************************************************************
+
+@mkVirtStkOffsets@ is given a list of arguments.  The first argument
+gets the {\em largest} virtual stack offset (remember, virtual offsets
+increase towards the top of stack).
+
+\begin{code}
+mkVirtStkOffsets :: VirtualSpAOffset 	-- Offset of the last allocated thing
+	  -> VirtualSpBOffset		-- ditto
+	  -> (a -> PrimKind)	-- to be able to grab kinds
+	  -> [a]			-- things to make offsets for
+	  -> (VirtualSpAOffset,		-- OUTPUTS: Topmost allocated word
+	      VirtualSpBOffset,		-- ditto
+	      [(a, VirtualSpAOffset)],	--  boxed things with offsets
+	      [(a, VirtualSpBOffset)])	--  unboxed things with offsets
+
+mkVirtStkOffsets init_SpA_offset init_SpB_offset kind_fun things
+  = let (boxeds, unboxeds)
+	    = separateByPtrFollowness kind_fun things
+	(last_SpA_offset, boxd_w_offsets)
+	    = mapAccumR computeOffset init_SpA_offset boxeds
+	(last_SpB_offset, ubxd_w_offsets)
+	    = mapAccumR computeOffset init_SpB_offset unboxeds
+    in
+	(last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets)
+  where
+    computeOffset offset thing
+      = (offset + (getKindSize . kind_fun) thing, (thing, offset+(1::Int)))
+\end{code}
+
+@mkStackAmodes@ is a higher-level version of @mkStackOffsets@.
+It starts from the tail-call locations.
+It returns a single list of addressing modes for the stack locations,
+and therefore is in the monad.
+
+It also adjusts the high water mark if necessary.
+
+\begin{code}
+mkStkAmodes :: VirtualSpAOffset	    	    -- Tail call positions
+    	    -> VirtualSpBOffset
+	    -> [CAddrMode]		    -- things to make offsets for
+	    -> FCode (VirtualSpAOffset,	    -- OUTPUTS: Topmost allocated word
+		      VirtualSpBOffset,	    -- ditto
+	              AbstractC)	    -- Assignments to appropriate stk slots
+
+mkStkAmodes tail_spa tail_spb things
+	    info_down (MkCgState absC binds usage)
+  = (result, MkCgState absC binds new_usage)
+  where
+    result = (last_SpA_offset, last_SpB_offset, mkAbstractCs abs_cs)
+
+    (last_SpA_offset, last_SpB_offset, ptrs_w_offsets, non_ptrs_w_offsets)
+    	= mkVirtStkOffsets tail_spa tail_spb getAmodeKind things
+
+    abs_cs
+	= [ CAssign (CVal (SpARel realSpA offset) PtrKind) thing
+	  | (thing, offset) <- ptrs_w_offsets
+	  ]
+	  ++
+	  [ CAssign (CVal (SpBRel realSpB offset) (getAmodeKind thing)) thing
+	  | (thing, offset) <- non_ptrs_w_offsets
+	  ]
+
+    ((vspA,fspA,realSpA,hwSpA), (vspB,fspB,realSpB,hwSpB), h_usage) = usage
+
+    new_usage = ((vspA,fspA,realSpA,max last_SpA_offset hwSpA),
+		 (vspB,fspB,realSpB,max last_SpB_offset hwSpB),
+		 h_usage)
+    -- No need to fiddle with virtual SpA etc because this call is
+    -- only done just before the end of a block
+
+
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
+%*									*
+%************************************************************************
+
+Allocate a virtual offset for something.
+\begin{code}
+allocAStack :: FCode VirtualSpAOffset
+
+allocAStack info_down (MkCgState absC binds
+		    ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
+  = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
+  where
+    push_virt_a = virt_a + 1
+
+    (chosen_slot, new_a_usage)
+	= if null free_a then
+		-- No free slots, so push a new one
+		-- We need to adjust the high-water mark
+		(push_virt_a, (push_virt_a, [], real_a, hw_a `max` push_virt_a))
+	  else
+		-- Free slots available, so use one
+		(free_slot, (virt_a, new_free_a, real_a, hw_a))
+
+    (free_slot, _) = head ([f | f@(slot, st) <- free_a, not (isStubbed st)] ++ free_a)
+		    -- Try to find an un-stubbed location;
+		    -- if none, return the first in the free list
+		    -- We'll only try this if free_a is known to be non-empty
+
+    -- Free list with the free_slot deleted
+    new_free_a = [ f | f@(s,_) <- free_a, s /= free_slot ]
+
+allocBStack :: Int -> FCode VirtualSpBOffset
+allocBStack size info_down (MkCgState absC binds
+				 (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
+  = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
+  where
+    push_virt_b = virt_b + size
+
+    (chosen_slot, new_b_usage)
+	= case find_block free_b of
+		Nothing -> (virt_b+1, (push_virt_b, free_b, real_b,
+				       hw_b `max` push_virt_b))
+				       -- Adjust high water mark
+
+		Just slot -> (slot, (virt_b, delete_block free_b slot, real_b, hw_b))
+
+    -- find_block looks for a contiguous chunk of free slots
+    find_block :: [VirtualSpBOffset] -> Maybe VirtualSpBOffset
+    find_block [] = Nothing
+    find_block (slot:slots)
+      | take size (slot:slots) == take size (repeat slot)
+      = Just slot
+      | otherwise
+      = find_block slots
+
+    delete_block free_b slot = [s | s <- free_b, (s<slot) || (s>=slot+size)]
+			      -- Retain slots which are not in the range
+			      -- slot..slot+size-1
+\end{code}
+
+@allocUpdateFrame@ allocates enough space for an update frame
+on the B stack, records the fact in the end-of-block info (in the ``args''
+fields), and passes on the old ``args'' fields to the enclosed code.
+
+This is all a bit disgusting.
+
+\begin{code}
+allocUpdateFrame :: Int			-- Size of frame
+		 -> CAddrMode		-- Return address which is to be the
+					-- top word of frame
+		 -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code) 	
+						-- Scope of update
+		 -> Code
+
+allocUpdateFrame size update_amode code
+	(MkCgInfoDown c_info statics (EndOfBlockInfo args_spa args_spb sequel))
+	(MkCgState absc binds (a_usage, (vB,rr,qq,hwB),h_usage))
+  = case sequel of
+
+	InRetReg -> code (args_spa, args_spb, vB)
+			 (MkCgInfoDown c_info statics new_eob_info)
+			 (MkCgState absc binds new_usage)
+
+	other    -> panic "allocUpdateFrame"
+
+  where
+    new_vB = vB + size
+    new_eob_info = EndOfBlockInfo args_spa new_vB (UpdateCode update_amode)
+    new_usage = (a_usage, (new_vB,rr,qq,hwB `max` new_vB), h_usage)
+\end{code}
+
+
+A knot-tying beast.
+
+\begin{code}
+getFinalStackHW :: (VirtualSpAOffset -> VirtualSpBOffset -> Code) -> Code
+getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
+  where
+    state1 = fcode hwSpA hwSpB info_down (MkCgState absC binds usages)
+    (MkCgState _ _ ((_,_,_, hwSpA), (_,_,_, hwSpB), _)) = state1
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[CgStackery-adjust]{Adjusting the stack pointers}
+%*									*
+%************************************************************************
+
+@adjustRealSpX@ generates code to alter the actual stack pointer, and
+adjusts the environment accordingly.  We are careful to push the
+conditional inside the abstract C code to avoid black holes.
+ToDo: combine together?
+
+These functions {\em do not} deal with high-water-mark adjustment.
+That's done by functions which allocate stack space.
+
+\begin{code}
+adjustRealSpA :: VirtualSpAOffset 	-- New offset for Arg stack ptr
+	      -> Code
+adjustRealSpA newRealSpA info_down (MkCgState absC binds
+					((vspA,fA,realSpA,hwspA),
+				 	b_usage, h_usage))
+  = MkCgState (mkAbsCStmts absC move_instrA) binds new_usage
+    where
+    move_instrA = if (newRealSpA == realSpA) then AbsCNop
+		 else (CAssign
+			    (CReg SpA)
+			    (CAddr (SpARel realSpA newRealSpA)))
+    new_usage = ((vspA, fA, newRealSpA, hwspA),
+		 b_usage, h_usage)
+
+adjustRealSpB :: VirtualSpBOffset 	-- New offset for Basic/Control stack ptr
+	      -> Code
+adjustRealSpB newRealSpB info_down (MkCgState absC binds
+					(a_usage,
+				 	(vspB,fB,realSpB,hwspB),
+				 	h_usage))
+  = MkCgState (mkAbsCStmts absC move_instrB) binds new_usage
+    where
+    move_instrB = if (newRealSpB == realSpB) then AbsCNop
+		 else (CAssign {-PtrKind-}
+			    (CReg SpB)
+			    (CAddr (SpBRel realSpB newRealSpB)))
+    new_usage = (a_usage,
+		 (vspB, fB, newRealSpB, hwspB),
+		 h_usage)
+
+adjustRealSps :: VirtualSpAOffset 	-- New offset for Arg stack ptr
+	      -> VirtualSpBOffset 	-- Ditto B stack
+	      -> Code
+adjustRealSps newRealSpA newRealSpB
+  = adjustRealSpA newRealSpA `thenC` adjustRealSpB newRealSpB
+\end{code}