[project @ 1996-01-11 14:06:51 by partain]

1 files changed, 190 insertions, 90 deletions

diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs
index 1051d26153..a5268beab7 100644
--- a/ghc/compiler/nativeGen/StixInteger.lhs
+++ b/ghc/compiler/nativeGen/StixInteger.lhs
@@ -33,9 +33,10 @@ import Util
 
 gmpTake1Return1 
     :: Target 
-    -> [CAddrMode]  	    -- result (3 parts)
-    -> FAST_STRING    	    -- function name
-    -> [CAddrMode]  	    -- argument (3 parts)
+    -> (CAddrMode,CAddrMode,CAddrMode)  -- result (3 parts)
+    -> FAST_STRING			-- function name
+    -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
+					-- argument (4 parts)
     -> SUniqSM StixTreeList
 
 argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
@@ -47,46 +48,71 @@ init2 = StCall SLIT("mpz_init") VoidKind [result2]
 init3 = StCall SLIT("mpz_init") VoidKind [result3]
 init4 = StCall SLIT("mpz_init") VoidKind [result4]
 
-gmpTake1Return1 target res rtn arg =
-    let	[ar,sr,dr] = map (amodeToStix target) res
-    	[liveness, aa,sa,da] = map (amodeToStix target) arg
-    	space = mpSpace target 2 1 [sa]
+-- hacking with Uncle Will:
+#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
+
+gmpTake1Return1 target_STRICT res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) =
+    let
+	a2stix  = amodeToStix target
+	data_hs = dataHS target
+
+	ar	= a2stix car
+	sr	= a2stix csr
+	dr	= a2stix cdr
+    	liveness= a2stix clive
+	aa	= a2stix caa
+	sa	= a2stix csa      
+	da	= a2stix cda      
+
+    	space = mpSpace data_hs 2 1 [sa]
     	oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
     	safeHp = saveLoc target Hp
     	save = StAssign PtrKind safeHp oldHp
-    	(a1,a2,a3) = toStruct target argument1 (aa,sa,da)
+    	(a1,a2,a3) = toStruct data_hs argument1 (aa,sa,da)
     	mpz_op = StCall rtn VoidKind [result2, argument1]
     	restore = StAssign PtrKind stgHp safeHp
-    	(r1,r2,r3) = fromStruct target result2 (ar,sr,dr)
+    	(r1,r2,r3) = fromStruct data_hs result2 (ar,sr,dr)
     in
-    	heapCheck target liveness space (StInt 0)
-    	    	    	    	    	    	    	`thenSUs` \ heap_chk ->
+    	heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
 
     	returnSUs (heap_chk . 
     	    (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
 
 gmpTake2Return1 
     :: Target 
-    -> [CAddrMode]  	    -- result (3 parts)
-    -> FAST_STRING    	    -- function name
-    -> [CAddrMode]  	    -- arguments (3 parts each)
+    -> (CAddrMode,CAddrMode,CAddrMode)	-- result (3 parts)
+    -> FAST_STRING    	    		-- function name
+    -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+					-- liveness + 2 arguments (3 parts each)
     -> SUniqSM StixTreeList
 
-gmpTake2Return1 target res rtn args =
-    let	[ar,sr,dr] = map (amodeToStix target) res
-    	[liveness, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args
-    	space = mpSpace target 3 1 [sa1, sa2]
+gmpTake2Return1 target_STRICT res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
+    let
+	a2stix  = amodeToStix target
+	data_hs = dataHS target
+
+	ar	= a2stix car
+	sr	= a2stix csr
+	dr	= a2stix cdr
+    	liveness= a2stix clive
+	aa1	= a2stix caa1
+	sa1	= a2stix csa1
+	da1	= a2stix cda1
+	aa2	= a2stix caa2
+	sa2	= a2stix csa2
+	da2	= a2stix cda2
+
+    	space = mpSpace data_hs 3 1 [sa1, sa2]
     	oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
     	safeHp = saveLoc target Hp
     	save = StAssign PtrKind safeHp oldHp
-    	(a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1)
-    	(a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2)
+    	(a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
+    	(a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
     	mpz_op = StCall rtn VoidKind [result3, argument1, argument2]
     	restore = StAssign PtrKind stgHp safeHp
-    	(r1,r2,r3) = fromStruct target result3 (ar,sr,dr)
+    	(r1,r2,r3) = fromStruct data_hs result3 (ar,sr,dr)
     in
-    	heapCheck target liveness space (StInt 0)
-    	    	    	    	    	    	    	`thenSUs` \ heap_chk ->
+    	heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
 
     	returnSUs (heap_chk .
     	    (\xs -> a1 : a2 : a3 : a4 : a5 : a6 
@@ -94,28 +120,46 @@ gmpTake2Return1 target res rtn args =
 
 gmpTake2Return2
     :: Target 
-    -> [CAddrMode]  	    -- results (3 parts each)
+    -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+    		  	    -- 2 results (3 parts each)
     -> FAST_STRING    	    -- function name
-    -> [CAddrMode]  	    -- arguments (3 parts each)
+    -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+    		  	    -- liveness + 2 arguments (3 parts each)
     -> SUniqSM StixTreeList
 
-gmpTake2Return2 target res rtn args =
-    let	[ar1,sr1,dr1, ar2,sr2,dr2] = map (amodeToStix target) res
-    	[liveness, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args
-    	space = StPrim IntMulOp [mpSpace target 2 1 [sa1, sa2], StInt 2]
+gmpTake2Return2 target_STRICT res@(car1,csr1,cdr1, car2,csr2,cdr2)
+		rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
+    let
+	a2stix  = amodeToStix target
+	data_hs = dataHS target
+
+	ar1	= a2stix car1     
+	sr1	= a2stix csr1     
+	dr1	= a2stix cdr1     
+	ar2	= a2stix car2     
+	sr2	= a2stix csr2     
+	dr2	= a2stix cdr2     
+    	liveness= a2stix clive
+	aa1	= a2stix caa1     
+	sa1	= a2stix csa1     
+	da1	= a2stix cda1     
+	aa2	= a2stix caa2     
+	sa2	= a2stix csa2
+	da2	= a2stix cda2
+
+    	space = StPrim IntMulOp [mpSpace data_hs 2 1 [sa1, sa2], StInt 2]
     	oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
     	safeHp = saveLoc target Hp
     	save = StAssign PtrKind safeHp oldHp
-    	(a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1)
-    	(a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2)
+    	(a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
+    	(a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
     	mpz_op = StCall rtn VoidKind [result3, result4, argument1, argument2]
     	restore = StAssign PtrKind stgHp safeHp
-    	(r1,r2,r3) = fromStruct target result3 (ar1,sr1,dr1)
-    	(r4,r5,r6) = fromStruct target result4 (ar2,sr2,dr2)
+    	(r1,r2,r3) = fromStruct data_hs result3 (ar1,sr1,dr1)
+    	(r4,r5,r6) = fromStruct data_hs result4 (ar2,sr2,dr2)
 
     in
-    	heapCheck target liveness space (StInt 0)
-    	    	    	    	    	    	    	`thenSUs` \ heap_chk ->
+    	heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
 
     	returnSUs (heap_chk .
     	    (\xs -> a1 : a2 : a3 : a4 : a5 : a6 
@@ -124,26 +168,38 @@ gmpTake2Return2 target res rtn args =
 
 \end{code}
 
-Although gmpCompare doesn't allocate space, it does temporarily use some
-space just beyond the heap pointer.  This is safe, because the enclosing
-routine has already guaranteed that this space will be available.  
-(See ``primOpHeapRequired.'')
+Although gmpCompare doesn't allocate space, it does temporarily use
+some space just beyond the heap pointer.  This is safe, because the
+enclosing routine has already guaranteed that this space will be
+available.  (See ``primOpHeapRequired.'')
 
 \begin{code}
 
 gmpCompare 
     :: Target 
     -> CAddrMode    	    -- result (boolean)
-    -> [CAddrMode]  	    -- arguments (3 parts each)
+    -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+    		  	    -- alloc hp + 2 arguments (3 parts each)
     -> SUniqSM StixTreeList
 
-gmpCompare target res args =
-    let	result = amodeToStix target res
-    	[hp, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args
+gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) =
+    let
+	a2stix  = amodeToStix target
+	data_hs = dataHS target
+
+	result	= a2stix res
+	hp	= a2stix chp      
+	aa1	= a2stix caa1
+	sa1	= a2stix csa1
+	da1	= a2stix cda1
+	aa2	= a2stix caa2
+	sa2	= a2stix csa2
+	da2	= a2stix cda2
+
     	argument1 = hp
     	argument2 = StIndex IntKind hp (StInt (toInteger mpIntSize))
-    	(a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1)
-    	(a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2)
+    	(a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
+    	(a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
     	mpz_cmp = StCall SLIT("mpz_cmp") IntKind [argument1, argument2]
     	r1 = StAssign IntKind result mpz_cmp
     in
@@ -158,13 +214,21 @@ See the comment above regarding the heap check (or lack thereof).
 gmpInteger2Int 
     :: Target 
     -> CAddrMode    	    -- result
-    -> [CAddrMode]  	    -- argument (3 parts)
+    -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
     -> SUniqSM StixTreeList
 
-gmpInteger2Int target res args =
-    let	result = amodeToStix target res
-    	[hp, aa,sa,da] = map (amodeToStix target) args
-    	(a1,a2,a3) = toStruct target hp (aa,sa,da)
+gmpInteger2Int target_STRICT res args@(chp, caa,csa,cda) =
+    let
+	a2stix  = amodeToStix target
+	data_hs = dataHS target
+
+	result	= a2stix res
+	hp	= a2stix chp
+	aa	= a2stix caa
+	sa	= a2stix csa
+	da	= a2stix cda
+
+    	(a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
     	mpz_get_si = StCall SLIT("mpz_get_si") IntKind [hp]
     	r1 = StAssign IntKind result mpz_get_si
     in
@@ -174,16 +238,23 @@ arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
 
 gmpInt2Integer 
     :: Target 
-    -> [CAddrMode]  	    -- result (3 parts)
-    -> [CAddrMode]  	    -- allocated heap, int to convert
+    -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
+    -> (CAddrMode, CAddrMode)	-- allocated heap, Int to convert
     -> SUniqSM StixTreeList
 
-gmpInt2Integer target res args@[_, n] =
-    getUniqLabelNCG					`thenSUs` \ zlbl ->
-    getUniqLabelNCG					`thenSUs` \ nlbl ->
-    getUniqLabelNCG					`thenSUs` \ jlbl ->
-    let	[ar,sr,dr] = map (amodeToStix target) res
-        [hp, i] = map (amodeToStix target) args
+gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) =
+    getUniqLabelNCG			`thenSUs` \ zlbl ->
+    getUniqLabelNCG			`thenSUs` \ nlbl ->
+    getUniqLabelNCG			`thenSUs` \ jlbl ->
+    let
+	a2stix = amodeToStix target
+
+	ar  = a2stix car
+	sr  = a2stix csr
+	dr  = a2stix cdr
+        hp  = a2stix chp
+	i   = a2stix n
+
     	h1 = StAssign PtrKind (StInd PtrKind hp) arrayOfData_info
     	size = varHeaderSize target (DataRep 0) + mIN_MP_INT_SIZE
     	h2 = StAssign IntKind (StInd IntKind (StIndex IntKind hp (StInt 1)))
@@ -222,13 +293,20 @@ gmpInt2Integer target res args@[_, n] =
 
 gmpString2Integer 
     :: Target 
-    -> [CAddrMode]  	    -- result (3 parts)
-    -> [CAddrMode]  	    -- liveness, string
+    -> (CAddrMode, CAddrMode, CAddrMode)    -- result (3 parts)
+    -> (CAddrMode, CAddrMode)		    -- liveness, string
     -> SUniqSM StixTreeList
 
-gmpString2Integer target res [liveness, str] =
+gmpString2Integer target_STRICT res@(car,csr,cdr) (liveness, str) =
     getUniqLabelNCG					`thenSUs` \ ulbl ->
-    let	[ar,sr,dr] = map (amodeToStix target) res
+    let
+	a2stix  = amodeToStix target
+	data_hs = dataHS target
+
+	ar = a2stix car
+	sr = a2stix csr
+	dr = a2stix cdr
+
     	len = case str of
     	    (CString s) -> _LENGTH_ s
     	    (CLit (MachStr s)) -> _LENGTH_ s
@@ -240,13 +318,13 @@ gmpString2Integer target res [liveness, str] =
     	save = StAssign PtrKind safeHp oldHp
     	result = StIndex IntKind stgHpLim (StInt (toInteger (-mpIntSize)))
     	set_str = StCall SLIT("mpz_init_set_str") IntKind
-    	    [result, amodeToStix target str, StInt 10]
+    	    [result, a2stix str, StInt 10]
     	test = StPrim IntEqOp [set_str, StInt 0]
     	cjmp = StCondJump ulbl test
     	abort = StCall SLIT("abort") VoidKind []
     	join = StLabel ulbl
     	restore = StAssign PtrKind stgHp safeHp
-    	(a1,a2,a3) = fromStruct target result (ar,sr,dr)
+    	(a1,a2,a3) = fromStruct data_hs result (ar,sr,dr)
     in
     	macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
     	    	    	    	    	    	    	`thenSUs` \ heap_chk ->
@@ -259,16 +337,28 @@ mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
 encodeFloatingKind 
     :: PrimKind 
     -> Target 
-    -> [CAddrMode]  	-- result
-    -> [CAddrMode]  	-- heap pointer for result, integer argument (3 parts), exponent
+    -> CAddrMode  	-- result
+    -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+		-- heap pointer for result, integer argument (3 parts), exponent
     -> SUniqSM StixTreeList
 
-encodeFloatingKind pk target [res] args =
-    let	result = amodeToStix target res
-    	[hp, aa,sa,da, expon] = map (amodeToStix target) args
-        pk' = if sizeof target FloatKind == sizeof target DoubleKind then DoubleKind
+encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) =
+    let
+	a2stix  = amodeToStix target
+	size_of = sizeof target
+	data_hs = dataHS target
+
+	result  = a2stix res
+	hp	= a2stix chp      
+	aa	= a2stix caa      
+	sa	= a2stix csa      
+	da	= a2stix cda      
+	expon	= a2stix cexpon
+
+        pk' = if size_of FloatKind == size_of DoubleKind
+	      then DoubleKind
               else pk
-    	(a1,a2,a3) = toStruct target hp (aa,sa,da)
+    	(a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
     	fn = case pk' of
     	    FloatKind -> SLIT("__encodeFloat")
     	    DoubleKind -> SLIT("__encodeDouble")
@@ -281,14 +371,27 @@ encodeFloatingKind pk target [res] args =
 decodeFloatingKind 
     :: PrimKind 
     -> Target 
-    -> [CAddrMode]  	    -- exponent result, integer result (3 parts)
-    -> [CAddrMode]  	    -- heap pointer for exponent, floating argument
+    -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
+			-- exponent result, integer result (3 parts)
+    -> (CAddrMode, CAddrMode)
+			-- heap pointer for exponent, floating argument
     -> SUniqSM StixTreeList
 
-decodeFloatingKind pk target res args =
-    let	[exponr,ar,sr,dr] = map (amodeToStix target) res
-        [hp, arg] = map (amodeToStix target) args
-        pk' = if sizeof target FloatKind == sizeof target DoubleKind then DoubleKind
+decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) =
+    let
+	a2stix  = amodeToStix target
+	size_of = sizeof target
+	data_hs = dataHS target
+
+	exponr	= a2stix cexponr  
+	ar	= a2stix car      
+	sr	= a2stix csr      
+	dr	= a2stix cdr      
+        hp	= a2stix chp      
+	arg	= a2stix carg     
+
+        pk' = if size_of FloatKind == size_of DoubleKind
+	      then DoubleKind
               else pk
         setup = StAssign PtrKind mpData_mantissa (StIndex IntKind hp (StInt 1))
     	fn = case pk' of
@@ -296,7 +399,7 @@ decodeFloatingKind pk target res args =
     	    DoubleKind -> SLIT("__decodeDouble")
     	    _ -> panic "decodeFloatingKind"
     	decode = StCall fn VoidKind [mantissa, hp, arg]
-    	(a1,a2,a3) = fromStruct target mantissa (ar,sr,dr)
+    	(a1,a2,a3) = fromStruct data_hs mantissa (ar,sr,dr)
     	a4 = StAssign IntKind exponr (StInd IntKind hp)
     in
     	returnSUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
@@ -317,18 +420,18 @@ mpSize base = StInd IntKind (StIndex IntKind base (StInt 1))
 mpData base = StInd PtrKind (StIndex IntKind base (StInt 2))
 
 mpSpace 
-    :: Target
+    :: StixTree		-- dataHs from Target
     -> Int  	    	-- gmp structures needed
     -> Int  	    	-- number of results
     -> [StixTree]	-- sizes to add for estimating result size
     -> StixTree  	-- total space
 
-mpSpace target gmp res sizes = 
+mpSpace data_hs gmp res sizes = 
     foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
   where
     sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
     fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
-    hdrs = StPrim IntMulOp [dataHS target, StInt (toInteger res)]
+    hdrs = StPrim IntMulOp [data_hs, StInt (toInteger res)]
 
 \end{code}
 
@@ -338,39 +441,36 @@ HpLim are our temporaries.)  Note that you must have performed a heap check
 which includes the space needed for these temporaries before you use them.
 
 \begin{code}
-
 mpStruct :: Int -> StixTree
 mpStruct n = StIndex IntKind stgHpLim (StInt (toInteger (-(n * mpIntSize))))
 
 toStruct 
-    :: Target
+    :: StixTree		-- dataHS, from Target
     -> StixTree 
     -> (StixTree, StixTree, StixTree) 
     -> (StixTree, StixTree, StixTree) 
 
-toStruct target str (alloc,size,arr) =
+toStruct data_hs str (alloc,size,arr) =
     let
     	f1 = StAssign IntKind (mpAlloc str) alloc
     	f2 = StAssign IntKind (mpSize str) size
-    	f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr (dataHS target))
+    	f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr data_hs)
     in
     	(f1, f2, f3)
 
 fromStruct 
-    :: Target
+    :: StixTree		-- dataHS, from Target
     -> StixTree 
     -> (StixTree, StixTree, StixTree) 
     -> (StixTree, StixTree, StixTree) 
 
-fromStruct target str (alloc,size,arr) =
+fromStruct data_hs str (alloc,size,arr) =
     let
     	e1 = StAssign IntKind alloc (mpAlloc str)
     	e2 = StAssign IntKind size (mpSize str)
     	e3 = StAssign PtrKind arr (StIndex PtrKind (mpData str) 
-    	    	    	    	    	    	   (StPrim IntNegOp [dataHS target]))
+    	    	    	    	    	    	   (StPrim IntNegOp [data_hs]))
     in
     	(e1, e2, e3)
-
-
 \end{code}