[project @ 2000-07-03 15:12:41 by simonmar]

[ghc-hetmet.git] / ghc / compiler / nativeGen / MachCode.lhs

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 12d4dbe..85373b1 100644 (file)
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -21,18 +21,22 @@ import OrdList              ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
 import AbsCSyn         ( MagicId )
 import AbsCUtils       ( magicIdPrimRep )
 import CallConv                ( CallConv )
 import AbsCSyn         ( MagicId )
 import AbsCUtils       ( magicIdPrimRep )
 import CallConv                ( CallConv )

-import CLabel          ( isAsmTemp, CLabel, pprCLabel_asm )
+import CLabel          ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )

 import Maybes          ( maybeToBool, expectJust )
 import PrimRep         ( isFloatingRep, PrimRep(..) )
 import PrimOp          ( PrimOp(..) )
 import CallConv                ( cCallConv )
 import Stix            ( getNatLabelNCG, StixTree(..),
                          StixReg(..), CodeSegment(..), 
 import Maybes          ( maybeToBool, expectJust )
 import PrimRep         ( isFloatingRep, PrimRep(..) )
 import PrimOp          ( PrimOp(..) )
 import CallConv                ( cCallConv )
 import Stix            ( getNatLabelNCG, StixTree(..),
                          StixReg(..), CodeSegment(..), 

-                          pprStixTrees, ppStixReg,
-                          NatM, thenNat, returnNat, mapNat, mapAndUnzipNat,
+                          pprStixTree, ppStixReg,
+                          NatM, thenNat, returnNat, mapNat, 
+                          mapAndUnzipNat, mapAccumLNat,

                           getDeltaNat, setDeltaNat
                        )
 import Outputable
                           getDeltaNat, setDeltaNat
                        )
 import Outputable

+import CmdLineOpts     ( opt_Static )
+
+infixr 3 `bind`

 
 \end{code}
 
 
 \end{code}
 

@@ -45,7 +49,6 @@ order.
 
 type InstrBlock = OrdList Instr
 
 
 type InstrBlock = OrdList Instr
 

-infixr 3 `bind`

 x `bind` f = f x
 
 \end{code}
 x `bind` f = f x
 
 \end{code}

@@ -63,15 +66,19 @@ stmt2Instrs stmt = case stmt of
                                                        LABEL lab)))
     StFunEnd lab   -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
                                     returnNat nilOL)
                                                        LABEL lab)))
     StFunEnd lab   -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
                                     returnNat nilOL)

+

     StLabel lab           -> returnNat (unitOL (LABEL lab))
 
     StLabel lab           -> returnNat (unitOL (LABEL lab))
 

-    StJump arg            -> genJump arg
-    StCondJump lab arg    -> genCondJump lab arg
-    StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
+    StJump arg            -> genJump (derefDLL arg)
+    StCondJump lab arg    -> genCondJump lab (derefDLL arg)
+
+    -- A call returning void, ie one done for its side-effects
+    StCall fn cconv VoidRep args -> genCCall fn
+                                             cconv VoidRep (map derefDLL args)

 
     StAssign pk dst src
 
     StAssign pk dst src

-      | isFloatingRep pk -> assignFltCode pk dst src
-      | otherwise       -> assignIntCode pk dst src
+      | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
+      | otherwise       -> assignIntCode pk (derefDLL dst) (derefDLL src)

 
     StFallThrough lbl
        -- When falling through on the Alpha, we still have to load pv
 
     StFallThrough lbl
        -- When falling through on the Alpha, we still have to load pv

@@ -86,11 +93,10 @@ stmt2Instrs stmt = case stmt of
       where
        getData :: StixTree -> NatM (InstrBlock, Imm)
 
       where
        getData :: StixTree -> NatM (InstrBlock, Imm)
 

-       getData (StInt i)    = returnNat (nilOL, ImmInteger i)
-       getData (StDouble d) = returnNat (nilOL, ImmDouble d)
-       getData (StLitLbl s) = returnNat (nilOL, ImmLab s)
-       getData (StCLbl l)   = returnNat (nilOL, ImmCLbl l)
-       getData (StString s) =
+       getData (StInt i)        = returnNat (nilOL, ImmInteger i)
+       getData (StDouble d)     = returnNat (nilOL, ImmDouble d)
+       getData (StCLbl l)       = returnNat (nilOL, ImmCLbl l)
+       getData (StString s)     =

            getNatLabelNCG                  `thenNat` \ lbl ->
            returnNat (toOL [LABEL lbl,
                             ASCII True (_UNPK_ s)],
            getNatLabelNCG                  `thenNat` \ lbl ->
            returnNat (toOL [LABEL lbl,
                             ASCII True (_UNPK_ s)],

@@ -99,6 +105,35 @@ stmt2Instrs stmt = case stmt of
        getData (StIndex rep (StCLbl lbl) (StInt off)) =
                returnNat (nilOL, 
                            ImmIndex lbl (fromInteger (off * sizeOf rep)))
        getData (StIndex rep (StCLbl lbl) (StInt off)) =
                returnNat (nilOL, 
                            ImmIndex lbl (fromInteger (off * sizeOf rep)))

+
+-- Walk a Stix tree, and insert dereferences to CLabels which are marked
+-- as labelDynamic.  stmt2Instrs calls derefDLL selectively, because
+-- not all such CLabel occurrences need this dereferencing -- SRTs don't
+-- for one.
+derefDLL :: StixTree -> StixTree
+derefDLL tree
+   | opt_Static   -- short out the entire deal if not doing DLLs
+   = tree
+   | otherwise
+   = qq tree
+     where
+        qq t
+           = case t of
+                StCLbl lbl -> if   labelDynamic lbl
+                              then StInd PtrRep (StCLbl lbl)
+                              else t
+                -- all the rest are boring
+                StIndex pk base offset -> StIndex pk (qq base) (qq offset)
+                StPrim pk args         -> StPrim pk (map qq args)
+                StInd pk addr          -> StInd pk (qq addr)
+                StCall who cc pk args  -> StCall who cc pk (map qq args)
+                StInt    _             -> t
+                StDouble _             -> t
+                StString _             -> t
+                StReg    _             -> t
+                StScratchWord _        -> t
+                _                      -> pprPanic "derefDLL: unhandled case" 
+                                                   (pprStixTree t)

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -131,12 +166,10 @@ mangleIndexTree (StIndex pk base off)
 \begin{code}
 maybeImm :: StixTree -> Maybe Imm
 
 \begin{code}
 maybeImm :: StixTree -> Maybe Imm
 

-maybeImm (StLitLbl s) = Just (ImmLab s)
-maybeImm (StCLbl   l) = Just (ImmCLbl l)
-
-maybeImm (StIndex rep (StCLbl l) (StInt off)) = 
-       Just (ImmIndex l (fromInteger (off * sizeOf rep)))
-
+maybeImm (StCLbl l)       
+   = Just (ImmCLbl l)
+maybeImm (StIndex rep (StCLbl l) (StInt off)) 
+   = Just (ImmIndex l (fromInteger (off * sizeOf rep)))

 maybeImm (StInt i)
   | i >= toInteger minInt && i <= toInteger maxInt
   = Just (ImmInt (fromInteger i))
 maybeImm (StInt i)
   | i >= toInteger minInt && i <= toInteger maxInt
   = Just (ImmInt (fromInteger i))

@@ -208,7 +241,7 @@ getRegister (StReg (StixMagicId stgreg))
                   -- cannae be Nothing
 
 getRegister (StReg (StixTemp u pk))
                   -- cannae be Nothing
 
 getRegister (StReg (StixTemp u pk))

-  = returnNat (Fixed pk (UnmappedReg u pk) nilOL)
+  = returnNat (Fixed pk (mkVReg u pk) nilOL)

 
 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
 
 
 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
 

@@ -479,13 +512,11 @@ getRegister (StDouble d)
 
   | d == 0.0
   = let code dst = unitOL (GLDZ dst)
 
   | d == 0.0
   = let code dst = unitOL (GLDZ dst)

-    in trace "nativeGen: GLDZ" 
-       (returnNat (Any DoubleRep code))
+    in  returnNat (Any DoubleRep code)

 
   | d == 1.0
   = let code dst = unitOL (GLD1 dst)
 
   | d == 1.0
   = let code dst = unitOL (GLD1 dst)

-    in trace "nativeGen: GLD1" 
-       returnNat (Any DoubleRep code)
+    in  returnNat (Any DoubleRep code)

 
   | otherwise
   = getNatLabelNCG                 `thenNat` \ lbl ->
 
   | otherwise
   = getNatLabelNCG                 `thenNat` \ lbl ->

@@ -575,7 +606,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
 
               other
                  -> pprPanic "getRegister(x86,unary primop)" 
 
               other
                  -> pprPanic "getRegister(x86,unary primop)" 

-                             (pprStixTrees [StPrim primop [x]])
+                             (pprStixTree (StPrim primop [x]))

 
 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
   = case primop of
 
 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
   = case primop of

@@ -659,7 +690,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
                                            [x, y])
       other
          -> pprPanic "getRegister(x86,dyadic primop)" 
                                            [x, y])
       other
          -> pprPanic "getRegister(x86,dyadic primop)" 

-                     (pprStixTrees [StPrim primop [x, y]])
+                     (pprStixTree (StPrim primop [x, y]))

   where
 
     --------------------
   where
 
     --------------------

@@ -858,7 +889,7 @@ getRegister leaf
     in
        returnNat (Any PtrRep code)
   | otherwise
     in
        returnNat (Any PtrRep code)
   | otherwise

-  = pprPanic "getRegister(x86)" (pprStixTrees [leaf])
+  = pprPanic "getRegister(x86)" (pprStixTree leaf)

   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x
   where
     imm = maybeImm leaf
     imm__2 = case imm of Just x -> x

@@ -870,7 +901,7 @@ getRegister leaf
 getRegister (StDouble d)
   = getNatLabelNCG                 `thenNat` \ lbl ->
     getNewRegNCG PtrRep            `thenNat` \ tmp ->
 getRegister (StDouble d)
   = getNatLabelNCG                 `thenNat` \ lbl ->
     getNewRegNCG PtrRep            `thenNat` \ tmp ->

-    let code dst = mkSeqInstrs [
+    let code dst = toOL [

            SEGMENT DataSegment,
            LABEL lbl,
            DATA DF [ImmDouble d],
            SEGMENT DataSegment,
            LABEL lbl,
            DATA DF [ImmDouble d],

@@ -1028,7 +1059,7 @@ getRegister (StInd pk mem)
        code = amodeCode amode
        src   = amodeAddr amode
        size = primRepToSize pk
        code = amodeCode amode
        src   = amodeAddr amode
        size = primRepToSize pk

-       code__2 dst = code . mkSeqInstr (LD size src dst)
+       code__2 dst = code `snocOL` LD size src dst

     in
        returnNat (Any pk code__2)
 
     in
        returnNat (Any pk code__2)
 

@@ -1036,14 +1067,14 @@ getRegister (StInt i)
   | fits13Bits i
   = let
        src = ImmInt (fromInteger i)
   | fits13Bits i
   = let
        src = ImmInt (fromInteger i)

-       code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
+       code dst = unitOL (OR False g0 (RIImm src) dst)

     in
        returnNat (Any IntRep code)
 
 getRegister leaf
   | maybeToBool imm
   = let
     in
        returnNat (Any IntRep code)
 
 getRegister leaf
   | maybeToBool imm
   = let

-       code dst = mkSeqInstrs [
+       code dst = toOL [

            SETHI (HI imm__2) dst,
            OR False dst (RIImm (LO imm__2)) dst]
     in
            SETHI (HI imm__2) dst,
            OR False dst (RIImm (LO imm__2)) dst]
     in

@@ -1225,11 +1256,11 @@ getAmode (StPrim IntAddOp [x, y])
     getRegister x              `thenNat` \ register1 ->
     getRegister y              `thenNat` \ register2 ->
     let
     getRegister x              `thenNat` \ register1 ->
     getRegister y              `thenNat` \ register2 ->
     let

-       code1 = registerCode register1 tmp1 []
+       code1 = registerCode register1 tmp1

        reg1  = registerName register1 tmp1
        reg1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 []
+       code2 = registerCode register2 tmp2

        reg2  = registerName register2 tmp2
        reg2  = registerName register2 tmp2

-       code__2 = asmSeqThen [code1, code2]
+       code__2 = code1 `appOL` code2

     in
     returnNat (Amode (AddrRegReg reg1 reg2) code__2)
 
     in
     returnNat (Amode (AddrRegReg reg1 reg2) code__2)
 

@@ -1237,7 +1268,7 @@ getAmode leaf
   | maybeToBool imm
   = getNewRegNCG PtrRep            `thenNat` \ tmp ->
     let
   | maybeToBool imm
   = getNewRegNCG PtrRep            `thenNat` \ tmp ->
     let

-       code = mkSeqInstr (SETHI (HI imm__2) tmp)
+       code = unitOL (SETHI (HI imm__2) tmp)

     in
     returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
   where
     in
     returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
   where

@@ -1519,7 +1550,7 @@ condIntCode cond x (StInt y)
        code = registerCode register tmp
        src1 = registerName register tmp
        src2 = ImmInt (fromInteger y)
        code = registerCode register tmp
        src1 = registerName register tmp
        src2 = ImmInt (fromInteger y)

-       code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
+       code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0

     in
     returnNat (CondCode False cond code__2)
 
     in
     returnNat (CondCode False cond code__2)
 

@@ -1529,12 +1560,12 @@ condIntCode cond x y
     getNewRegNCG IntRep                `thenNat` \ tmp1 ->
     getNewRegNCG IntRep                `thenNat` \ tmp2 ->
     let
     getNewRegNCG IntRep                `thenNat` \ tmp1 ->
     getNewRegNCG IntRep                `thenNat` \ tmp2 ->
     let

-       code1 = registerCode register1 tmp1 []
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 []
+       code2 = registerCode register2 tmp2

        src2  = registerName register2 tmp2
        src2  = registerName register2 tmp2

-       code__2 = asmSeqThen [code1, code2] .
-               mkSeqInstr (SUB False True src1 (RIReg src2) g0)
+       code__2 = code1 `appOL` code2 `snocOL`
+                 SUB False True src1 (RIReg src2) g0

     in
     returnNat (CondCode False cond code__2)
 
     in
     returnNat (CondCode False cond code__2)
 

@@ -1548,7 +1579,7 @@ condFltCode cond x y
                                `thenNat` \ tmp2 ->
     getNewRegNCG DoubleRep     `thenNat` \ tmp ->
     let
                                `thenNat` \ tmp2 ->
     getNewRegNCG DoubleRep     `thenNat` \ tmp ->
     let

-       promote x = asmInstr (FxTOy F DF x tmp)
+       promote x = FxTOy F DF x tmp

 
        pk1   = registerRep register1
        code1 = registerCode register1 tmp1
 
        pk1   = registerRep register1
        code1 = registerCode register1 tmp1

@@ -1560,14 +1591,14 @@ condFltCode cond x y
 
        code__2 =
                if pk1 == pk2 then
 
        code__2 =
                if pk1 == pk2 then

-                   asmSeqThen [code1 [], code2 []] .
-                   mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
+                   code1 `appOL` code2 `snocOL`
+                   FCMP True (primRepToSize pk1) src1 src2

                else if pk1 == FloatRep then
                else if pk1 == FloatRep then

-                   asmSeqThen [code1 (promote src1), code2 []] .
-                   mkSeqInstr (FCMP True DF tmp src2)
+                   code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+                   FCMP True DF tmp src2

                else
                else

-                   asmSeqThen [code1 [], code2 (promote src2)] .
-                   mkSeqInstr (FCMP True DF src1 tmp)
+                   code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+                   FCMP True DF src1 tmp

     in
     returnNat (CondCode True cond code__2)
 
     in
     returnNat (CondCode True cond code__2)
 

@@ -1724,12 +1755,12 @@ assignIntCode pk (StInd _ dst) src
     getAmode dst                   `thenNat` \ amode ->
     getRegister src                        `thenNat` \ register ->
     let
     getAmode dst                   `thenNat` \ amode ->
     getRegister src                        `thenNat` \ register ->
     let

-       code1   = amodeCode amode []
+       code1   = amodeCode amode

        dst__2  = amodeAddr amode
        dst__2  = amodeAddr amode

-       code2   = registerCode register tmp []
+       code2   = registerCode register tmp

        src__2  = registerName register tmp
        sz      = primRepToSize pk
        src__2  = registerName register tmp
        sz      = primRepToSize pk

-       code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
+       code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2

     in
     returnNat code__2
 
     in
     returnNat code__2
 

@@ -1741,7 +1772,7 @@ assignIntCode pk dst src
        code    = registerCode register2 dst__2
        src__2  = registerName register2 dst__2
        code__2 = if isFixed register2
        code    = registerCode register2 dst__2
        src__2  = registerName register2 dst__2
        code__2 = if isFixed register2

-                 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
+                 then code `snocOL` OR False g0 (RIReg src__2) dst__2

                  else code
     in
     returnNat code__2
                  else code
     in
     returnNat code__2

@@ -1846,18 +1877,17 @@ assignFltCode pk (StInd _ dst) src
        sz      = primRepToSize pk
        dst__2  = amodeAddr amode
 
        sz      = primRepToSize pk
        dst__2  = amodeAddr amode
 

-       code1   = amodeCode amode []
-       code2   = registerCode register tmp1 []
+       code1   = amodeCode amode
+       code2   = registerCode register tmp1

 
        src__2  = registerName register tmp1
        pk__2   = registerRep register
        sz__2   = primRepToSize pk__2
 
 
        src__2  = registerName register tmp1
        pk__2   = registerRep register
        sz__2   = primRepToSize pk__2
 

-       code__2 = asmSeqThen [code1, code2] ++
-           if pk == pk__2 then
-                   mkSeqInstr (ST sz src__2 dst__2)
-           else
-               mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
+       code__2 = code1 `appOL` code2 `appOL`
+           if   pk == pk__2 
+            then unitOL (ST sz src__2 dst__2)
+           else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]

     in
     returnNat code__2
 
     in
     returnNat code__2
 

@@ -1882,9 +1912,9 @@ assignFltCode pk dst src
 
        code__2 = 
                if pk /= pk__2 then
 
        code__2 = 
                if pk /= pk__2 then

-                    code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
+                    code `snocOL` FxTOy sz__2 sz src__2 dst__2

                else if isFixed register2 then
                else if isFixed register2 then

-                    code . mkSeqInstr (FMOV sz src__2 dst__2)
+                    code `snocOL` FMOV sz src__2 dst__2

                else
                     code
     in
                else
                     code
     in

@@ -1964,8 +1994,8 @@ genJump tree
 #if sparc_TARGET_ARCH
 
 genJump (StCLbl lbl)
 #if sparc_TARGET_ARCH
 
 genJump (StCLbl lbl)

-  | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
-  | otherwise     = returnInstrs [CALL target 0 True, NOP]
+  | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
+  | otherwise     = returnNat (toOL [CALL target 0 True, NOP])

   where
     target = ImmCLbl lbl
 
   where
     target = ImmCLbl lbl
 

@@ -1976,7 +2006,7 @@ genJump tree
        code   = registerCode register tmp
        target = registerName register tmp
     in
        code   = registerCode register tmp
        target = registerName register tmp
     in

-    returnSeq code [JMP (AddrRegReg target g0), NOP]
+    returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)

 
 #endif {- sparc_TARGET_ARCH -}
 \end{code}
 
 #endif {- sparc_TARGET_ARCH -}
 \end{code}

@@ -2177,11 +2207,13 @@ genCondJump lbl bool
        cond   = condName condition
        target = ImmCLbl lbl
     in
        cond   = condName condition
        target = ImmCLbl lbl
     in

-    returnSeq code (
-    if condFloat condition then
-       [NOP, BF cond False target, NOP]
-    else
-       [BI cond False target, NOP]
+    returnNat (
+       code `appOL` 
+       toOL (
+         if   condFloat condition 
+         then [NOP, BF cond False target, NOP]
+         else [BI cond False target, NOP]
+       )

     )
 
 #endif {- sparc_TARGET_ARCH -}
     )
 
 #endif {- sparc_TARGET_ARCH -}

@@ -2313,7 +2345,7 @@ genCCall fn cconv kind args
     -- ToDo:needed (WDP 96/03) ???
     fn__2 = case (_HEAD_ fn) of
              '.' -> ImmLit (ptext fn)
     -- ToDo:needed (WDP 96/03) ???
     fn__2 = case (_HEAD_ fn) of
              '.' -> ImmLit (ptext fn)

-             _   -> ImmLab (ptext fn)
+             _   -> ImmLab False (ptext fn)

 
     arg_size DF = 8
     arg_size F  = 8
 
     arg_size DF = 8
     arg_size F  = 8

@@ -2363,15 +2395,20 @@ genCCall fn cconv kind args
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #if sparc_TARGET_ARCH
 
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #if sparc_TARGET_ARCH
 

+-- Implement this!  It should be im MachRegs.lhs, not here.
+allArgRegs :: [Reg]
+allArgRegs = error "nativeGen(sparc): allArgRegs"
+

 genCCall fn cconv kind args
   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
                          `thenNat` \ ((unused,_), argCode) ->
     let
 genCCall fn cconv kind args
   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
                          `thenNat` \ ((unused,_), argCode) ->
     let

+

        nRegs = length allArgRegs - length unused
        call = CALL fn__2 nRegs False
        nRegs = length allArgRegs - length unused
        call = CALL fn__2 nRegs False

-       code = asmSeqThen (map ($ []) argCode)
+       code = concatOL argCode

     in
     in

-       returnSeq code [call, NOP]
+       returnNat (code `snocOL` call `snocOL` NOP)

   where
     -- function names that begin with '.' are assumed to be special
     -- internally generated names like '.mul,' which don't get an
   where
     -- function names that begin with '.' are assumed to be special
     -- internally generated names like '.mul,' which don't get an

@@ -2379,7 +2416,7 @@ genCCall fn cconv kind args
     -- ToDo:needed (WDP 96/03) ???
     fn__2 = case (_HEAD_ fn) of
              '.' -> ImmLit (ptext fn)
     -- ToDo:needed (WDP 96/03) ???
     fn__2 = case (_HEAD_ fn) of
              '.' -> ImmLit (ptext fn)

-             _   -> ImmLab (ptext fn)
+             _   -> ImmLab False (ptext fn)

 
     ------------------------------------
     {-  Try to get a value into a specific register (or registers) for
 
     ------------------------------------
     {-  Try to get a value into a specific register (or registers) for

@@ -2410,25 +2447,36 @@ genCCall fn cconv kind args
            src  = registerName register reg
            pk   = registerRep register
        in
            src  = registerName register reg
            pk   = registerRep register
        in

-       returnNat (case pk of
+       returnNat (
+         case pk of

            DoubleRep ->
                case dsts of
            DoubleRep ->
                case dsts of

-                   [] -> (([], offset + 1), code . mkSeqInstrs [
+                  [] -> ( ([], offset + 1), 
+                            code `snocOL`

                            -- conveniently put the second part in the right stack
                            -- location, and load the first part into %o5
                            -- conveniently put the second part in the right stack
                            -- location, and load the first part into %o5

-                           ST DF src (spRel (offset - 1)),
-                           LD W (spRel (offset - 1)) dst])
-                   (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
-                           ST DF src (spRel (-2)),
-                           LD W (spRel (-2)) dst,
-                           LD W (spRel (-1)) dst__2])
-           FloatRep -> ((dsts, offset), code . mkSeqInstrs [
-                           ST F src (spRel (-2)),
-                           LD W (spRel (-2)) dst])
-           _ -> ((dsts, offset), if isFixed register then
-                                 code . mkSeqInstr (OR False g0 (RIReg src) dst)
-                                 else code))
-
+                           ST DF src (spRel (offset - 1)) `snocOL`
+                           LD W (spRel (offset - 1)) dst
+                         )
+                  (dst__2:dsts__2) 
+                       -> ( (dsts__2, offset), 
+                            code `snocOL`
+                           ST DF src (spRel (-2)) `snocOL`
+                           LD W (spRel (-2)) dst `snocOL`
+                           LD W (spRel (-1)) dst__2
+                          )
+           FloatRep 
+               -> ( (dsts, offset), 
+                    code `snocOL`
+                   ST F src (spRel (-2)) `snocOL`
+                   LD W (spRel (-2)) dst
+                  )
+           _  -> ( (dsts, offset), 
+                    if   isFixed register 
+                    then code `snocOL` OR False g0 (RIReg src) dst
+                   else code
+                  )
+        )

     -- Once we have run out of argument registers, we move to the
     -- stack...
 
     -- Once we have run out of argument registers, we move to the
     -- stack...
 

@@ -2443,7 +2491,8 @@ genCCall fn cconv kind args
            sz    = primRepToSize pk
            words = if pk == DoubleRep then 2 else 1
        in
            sz    = primRepToSize pk
            words = if pk == DoubleRep then 2 else 1
        in

-       returnNat (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
+       returnNat ( ([], offset + words), 
+                    code `snocOL` ST sz src (spRel offset) )

 
 #endif {- sparc_TARGET_ARCH -}
 \end{code}
 
 #endif {- sparc_TARGET_ARCH -}
 \end{code}

@@ -2517,7 +2566,7 @@ condIntReg EQQ x (StInt 0)
     let
        code = registerCode register tmp
        src  = registerName register tmp
     let
        code = registerCode register tmp
        src  = registerName register tmp

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            SUB False True g0 (RIReg src) g0,
            SUB True False g0 (RIImm (ImmInt (-1))) dst]
     in
            SUB False True g0 (RIReg src) g0,
            SUB True False g0 (RIImm (ImmInt (-1))) dst]
     in

@@ -2529,11 +2578,11 @@ condIntReg EQQ x y
     getNewRegNCG IntRep                `thenNat` \ tmp1 ->
     getNewRegNCG IntRep                `thenNat` \ tmp2 ->
     let
     getNewRegNCG IntRep                `thenNat` \ tmp1 ->
     getNewRegNCG IntRep                `thenNat` \ tmp2 ->
     let

-       code1 = registerCode register1 tmp1 []
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 []
+       code2 = registerCode register2 tmp2

        src2  = registerName register2 tmp2
        src2  = registerName register2 tmp2

-       code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [
+       code__2 dst = code1 `appOL` code2 `appOL` toOL [

            XOR False src1 (RIReg src2) dst,
            SUB False True g0 (RIReg dst) g0,
            SUB True False g0 (RIImm (ImmInt (-1))) dst]
            XOR False src1 (RIReg src2) dst,
            SUB False True g0 (RIReg dst) g0,
            SUB True False g0 (RIImm (ImmInt (-1))) dst]

@@ -2546,7 +2595,7 @@ condIntReg NE x (StInt 0)
     let
        code = registerCode register tmp
        src  = registerName register tmp
     let
        code = registerCode register tmp
        src  = registerName register tmp

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            SUB False True g0 (RIReg src) g0,
            ADD True False g0 (RIImm (ImmInt 0)) dst]
     in
            SUB False True g0 (RIReg src) g0,
            ADD True False g0 (RIImm (ImmInt 0)) dst]
     in

@@ -2558,11 +2607,11 @@ condIntReg NE x y
     getNewRegNCG IntRep                `thenNat` \ tmp1 ->
     getNewRegNCG IntRep                `thenNat` \ tmp2 ->
     let
     getNewRegNCG IntRep                `thenNat` \ tmp1 ->
     getNewRegNCG IntRep                `thenNat` \ tmp2 ->
     let

-       code1 = registerCode register1 tmp1 []
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 []
+       code2 = registerCode register2 tmp2

        src2  = registerName register2 tmp2
        src2  = registerName register2 tmp2

-       code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [
+       code__2 dst = code1 `appOL` code2 `appOL` toOL [

            XOR False src1 (RIReg src2) dst,
            SUB False True g0 (RIReg dst) g0,
            ADD True False g0 (RIImm (ImmInt 0)) dst]
            XOR False src1 (RIReg src2) dst,
            SUB False True g0 (RIReg dst) g0,
            ADD True False g0 (RIImm (ImmInt 0)) dst]

@@ -2576,7 +2625,7 @@ condIntReg cond x y
     let
        code = condCode condition
        cond = condName condition
     let
        code = condCode condition
        cond = condName condition

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            BI cond False (ImmCLbl lbl1), NOP,
            OR False g0 (RIImm (ImmInt 0)) dst,
            BI ALWAYS False (ImmCLbl lbl2), NOP,
            BI cond False (ImmCLbl lbl1), NOP,
            OR False g0 (RIImm (ImmInt 0)) dst,
            BI ALWAYS False (ImmCLbl lbl2), NOP,

@@ -2593,7 +2642,7 @@ condFltReg cond x y
     let
        code = condCode condition
        cond = condName condition
     let
        code = condCode condition
        cond = condName condition

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            NOP,
            BF cond False (ImmCLbl lbl1), NOP,
            OR False g0 (RIImm (ImmInt 0)) dst,
            NOP,
            BF cond False (ImmCLbl lbl1), NOP,
            OR False g0 (RIImm (ImmInt 0)) dst,

@@ -2917,7 +2966,7 @@ trivialCode instr x (StInt y)
        code = registerCode register tmp
        src1 = registerName register tmp
        src2 = ImmInt (fromInteger y)
        code = registerCode register tmp
        src1 = registerName register tmp
        src2 = ImmInt (fromInteger y)

-       code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
+       code__2 dst = code `snocOL` instr src1 (RIImm src2) dst

     in
     returnNat (Any IntRep code__2)
 
     in
     returnNat (Any IntRep code__2)
 

@@ -2927,12 +2976,12 @@ trivialCode instr x y
     getNewRegNCG IntRep                `thenNat` \ tmp1 ->
     getNewRegNCG IntRep                `thenNat` \ tmp2 ->
     let
     getNewRegNCG IntRep                `thenNat` \ tmp1 ->
     getNewRegNCG IntRep                `thenNat` \ tmp2 ->
     let

-       code1 = registerCode register1 tmp1 []
+       code1 = registerCode register1 tmp1

        src1  = registerName register1 tmp1
        src1  = registerName register1 tmp1

-       code2 = registerCode register2 tmp2 []
+       code2 = registerCode register2 tmp2

        src2  = registerName register2 tmp2
        src2  = registerName register2 tmp2

-       code__2 dst = asmSeqThen [code1, code2] .
-                    mkSeqInstr (instr src1 (RIReg src2) dst)
+       code__2 dst = code1 `appOL` code2 `snocOL`
+                     instr src1 (RIReg src2) dst

     in
     returnNat (Any IntRep code__2)
 
     in
     returnNat (Any IntRep code__2)
 

@@ -2946,7 +2995,7 @@ trivialFCode pk instr x y
                                `thenNat` \ tmp2 ->
     getNewRegNCG DoubleRep     `thenNat` \ tmp ->
     let
                                `thenNat` \ tmp2 ->
     getNewRegNCG DoubleRep     `thenNat` \ tmp ->
     let

-       promote x = asmInstr (FxTOy F DF x tmp)
+       promote x = FxTOy F DF x tmp

 
        pk1   = registerRep register1
        code1 = registerCode register1 tmp1
 
        pk1   = registerRep register1
        code1 = registerCode register1 tmp1

@@ -2958,14 +3007,14 @@ trivialFCode pk instr x y
 
        code__2 dst =
                if pk1 == pk2 then
 
        code__2 dst =
                if pk1 == pk2 then

-                   asmSeqThen [code1 [], code2 []] .
-                   mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
+                   code1 `appOL` code2 `snocOL`
+                   instr (primRepToSize pk) src1 src2 dst

                else if pk1 == FloatRep then
                else if pk1 == FloatRep then

-                   asmSeqThen [code1 (promote src1), code2 []] .
-                   mkSeqInstr (instr DF tmp src2 dst)
+                   code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+                   instr DF tmp src2 dst

                else
                else

-                   asmSeqThen [code1 [], code2 (promote src2)] .
-                   mkSeqInstr (instr DF src1 tmp dst)
+                   code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+                   instr DF src1 tmp dst

     in
     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
 
     in
     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
 

@@ -2976,7 +3025,7 @@ trivialUCode instr x
     let
        code = registerCode register tmp
        src  = registerName register tmp
     let
        code = registerCode register tmp
        src  = registerName register tmp

-       code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
+       code__2 dst = code `snocOL` instr (RIReg src) dst

     in
     returnNat (Any IntRep code__2)
 
     in
     returnNat (Any IntRep code__2)
 

@@ -2987,7 +3036,7 @@ trivialUFCode pk instr x
     let
        code = registerCode register tmp
        src  = registerName register tmp
     let
        code = registerCode register tmp
        src  = registerName register tmp

-       code__2 dst = code . mkSeqInstr (instr src dst)
+       code__2 dst = code `snocOL` instr src dst

     in
     returnNat (Any pk code__2)
 
     in
     returnNat (Any pk code__2)
 

@@ -3105,7 +3154,7 @@ coerceInt2FP pk x
        code = registerCode register reg
        src  = registerName register reg
 
        code = registerCode register reg
        src  = registerName register reg
 

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            ST W src (spRel (-2)),
            LD W (spRel (-2)) dst,
            FxTOy W (primRepToSize pk) dst dst]
            ST W src (spRel (-2)),
            LD W (spRel (-2)) dst,
            FxTOy W (primRepToSize pk) dst dst]

@@ -3122,7 +3171,7 @@ coerceFP2Int x
        src  = registerName register reg
        pk   = registerRep  register
 
        src  = registerName register reg
        pk   = registerRep  register
 

-       code__2 dst = code . mkSeqInstrs [
+       code__2 dst = code `appOL` toOL [

            FxTOy (primRepToSize pk) W src tmp,
            ST W tmp (spRel (-2)),
            LD W (spRel (-2)) dst]
            FxTOy (primRepToSize pk) W src tmp,
            ST W tmp (spRel (-2)),
            LD W (spRel (-2)) dst]

@@ -3186,11 +3235,11 @@ chrCode (StInd pk mem)
        src_off = addrOffset src 3
        src__2  = case src_off of Just x -> x
        code__2 dst = if maybeToBool src_off then
        src_off = addrOffset src 3
        src__2  = case src_off of Just x -> x
        code__2 dst = if maybeToBool src_off then

-                       code . mkSeqInstr (LD BU src__2 dst)
+                       code `snocOL` LD BU src__2 dst

                    else
                    else

-                       code . mkSeqInstrs [
-                           LD (primRepToSize pk) src dst,
-                           AND False dst (RIImm (ImmInt 255)) dst]
+                       code `snocOL`
+                       LD (primRepToSize pk) src dst  `snocOL`
+                       AND False dst (RIImm (ImmInt 255)) dst

     in
     returnNat (Any pk code__2)
 
     in
     returnNat (Any pk code__2)
 

@@ -3200,7 +3249,7 @@ chrCode x
     let
        code = registerCode register reg
        src  = registerName register reg
     let
        code = registerCode register reg
        src  = registerName register reg

-       code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
+       code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst

     in
     returnNat (Any IntRep code__2)
 
     in
     returnNat (Any IntRep code__2)