From: sof Date: Fri, 14 Aug 1998 12:00:33 +0000 (+0000) Subject: [project @ 1998-08-14 12:00:22 by sof] X-Git-Tag: Approx_2487_patches~391 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=91b4fb8d9cd5bdefb552e643df8bedab0ec2a526;p=ghc-hetmet.git [project @ 1998-08-14 12:00:22 by sof] StCall now takes extra callconv arg; StixPrim.primCode doesn't flush stdout and stderr anymore (it's done in the .hc code) --- diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 759fedc..7ad77c8 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -367,7 +367,7 @@ comparison tree. (Perhaps this could be tuned.) \begin{code} intTag :: Literal -> Integer - intTag (MachChar c) = toInteger (ord c) + intTag (MachChar c) = fromInt (ord c) intTag (MachInt i _) = i intTag _ = panic "intTag" @@ -442,8 +442,8 @@ already finish with a jump to the join point. mkJumpTable am alts lowTag highTag dflt = getUniqLabelNCG `thenUs` \ utlbl -> mapUs genLabel alts `thenUs` \ branches -> - let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag]) - cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag]) + let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)]) + cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)]) offset = StPrim IntSubOp [am, StInt lowTag] diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 1edfe9a..fe9828c 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -156,8 +156,8 @@ genericOpt (StJump addr) = StJump (genericOpt addr) genericOpt (StCondJump addr test) = StCondJump addr (genericOpt test) -genericOpt (StCall fn pk args) - = StCall fn pk (map genericOpt args) +genericOpt (StCall fn cconv pk args) + = StCall fn cconv pk (map genericOpt args) \end{code} Fold indices together when the types match: @@ -249,7 +249,6 @@ primOpt op args@[x, y@(StInt 0)] OrOp -> x XorOp -> x SllOp -> x - SraOp -> x SrlOp -> x ISllOp -> x ISraOp -> x @@ -271,10 +270,10 @@ primOpt op args@[x, y@(StInt n)] = case op of IntMulOp -> case exactLog2 n of Nothing -> StPrim op args - Just p -> StPrim SllOp [x, StInt p] + Just p -> StPrim ISllOp [x, StInt p] IntQuotOp -> case exactLog2 n of Nothing -> StPrim op args - Just p -> StPrim SraOp [x, StInt p] + Just p -> StPrim ISrlOp [x, StInt p] _ -> StPrim op args \end{code} diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index 106fe29..8862f53 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -22,8 +22,7 @@ import OrdList ( mkEmptyList, mkUnitList, mkSeqList, mkParList, ) import Stix ( StixTree ) import Unique ( mkBuiltinUnique ) -import Util ( mapAccumB, panic ) -import GlaExts ( trace ) +import Util ( mapAccumB, panic, trace ) import Outputable \end{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index b9f66e8..b0aefde 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -19,11 +19,13 @@ import MachRegs import AbsCSyn ( MagicId ) import AbsCUtils ( magicIdPrimRep ) +import CallConv ( CallConv ) import CLabel ( isAsmTemp, CLabel ) import Maybes ( maybeToBool, expectJust ) import OrdList -- quite a bit of it import PrimRep ( isFloatingRep, PrimRep(..) ) import PrimOp ( PrimOp(..), showPrimOp ) +import CallConv ( cCallConv ) import Stix ( getUniqLabelNCG, StixTree(..), StixReg(..), CodeSegment(..) ) @@ -47,7 +49,7 @@ stmt2Instrs stmt = case stmt of StJump arg -> genJump arg StCondJump lab arg -> genCondJump lab arg - StCall fn VoidRep args -> genCCall fn VoidRep args + StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args StAssign pk dst src | isFloatingRep pk -> assignFltCode pk dst src @@ -212,8 +214,8 @@ getRegister (StReg (StixTemp u pk)) getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) -getRegister (StCall fn kind args) - = genCCall fn kind args `thenUs` \ call -> +getRegister (StCall fn cconv kind args) + = genCCall fn cconv kind args `thenUs` \ call -> returnUs (Fixed kind reg call) where reg = if isFloatingRep kind @@ -308,7 +310,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps Double2FloatOp -> coerceFltCode x Float2DoubleOp -> coerceFltCode x - other_op -> getRegister (StCall fn DoubleRep [x]) + other_op -> getRegister (StCall fn cconv DoubleRep [x]) where fn = case other_op of FloatExpOp -> SLIT("exp") @@ -405,15 +407,14 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps OrOp -> trivialCode OR x y XorOp -> trivialCode XOR x y SllOp -> trivialCode SLL x y - SraOp -> trivialCode SRA x y SrlOp -> trivialCode SRL x y ISllOp -> panic "AlphaGen:isll" - ISraOp -> panic "AlphaGen:isra" + ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" ISrlOp -> panic "AlphaGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y]) - DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y]) + FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) + DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) where {- ------------------------------------------------------------ Some bizarre special code for getting condition codes into @@ -556,7 +557,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps then StPrim Float2DoubleOp [x] else x in - getRegister (StCall fn DoubleRep [x]) + getRegister (StCall fn cCallConv DoubleRep [x]) where (is_float_op, fn) = case primop of @@ -668,17 +669,16 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps -} SllOp -> shift_code (SHL L) x y {-False-} - SraOp -> shift_code (SAR L) x y {-False-} SrlOp -> shift_code (SHR L) x y {-False-} {- ToDo: nuke? -} ISllOp -> panic "I386Gen:isll" - ISraOp -> panic "I386Gen:isra" + ISraOp -> shift_code (SAR L) x y {-False-} --panic "I386Gen:isra" ISrlOp -> panic "I386Gen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y]) + FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y]) + DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y]) where shift_code :: (Operand -> Operand -> Instr) -> StixTree @@ -970,7 +970,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps then StPrim Float2DoubleOp [x] else x in - getRegister (StCall fn DoubleRep [x]) + getRegister (StCall fn cCallConv DoubleRep [x]) where (is_float_op, fn) = case primop of @@ -1073,19 +1073,18 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps OrOp -> trivialCode (OR False) x y XorOp -> trivialCode (XOR False) x y SllOp -> trivialCode SLL x y - SraOp -> trivialCode SRA x y SrlOp -> trivialCode SRL x y ISllOp -> panic "SparcGen:isll" - ISraOp -> panic "SparcGen:isra" + ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra" ISrlOp -> panic "SparcGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y]) + FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y]) + DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y]) -- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!" where - imul_div fn x y = getRegister (StCall fn IntRep [x, y]) + imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y]) getRegister (StInd pk mem) = getAmode mem `thenUs` \ amode -> @@ -2234,13 +2233,14 @@ register allocator. \begin{code} genCCall :: FAST_STRING -- function to call + -> CallConv -> PrimRep -- type of the result -> [StixTree] -- arguments (of mixed type) -> UniqSM InstrBlock #if alpha_TARGET_ARCH -genCCall fn kind args +genCCall fn cconv kind args = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args `thenUs` \ ((unused,_), argCode) -> let @@ -2308,7 +2308,7 @@ genCCall fn kind args -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -genCCall fn kind [StInt i] +genCCall fn cconv kind [StInt i] | fn == SLIT ("PerformGC_wrapper") = let call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), @@ -2329,7 +2329,7 @@ genCCall fn kind [StInt i] returnInstrs call -} -genCCall fn kind args +genCCall fn cconv kind args = mapUs get_call_arg args `thenUs` \ argCode -> let nargs = length args @@ -2401,7 +2401,7 @@ genCCall fn kind args -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH -genCCall fn kind args +genCCall fn cconv kind args = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args `thenUs` \ ((unused,_), argCode) -> let diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 06cbae1..c30d6cf 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -596,6 +596,12 @@ baseRegOffset (FloatReg ILIT(3)) = OFFSET_Flt3 baseRegOffset (FloatReg ILIT(4)) = OFFSET_Flt4 baseRegOffset (DoubleReg ILIT(1)) = OFFSET_Dbl1 baseRegOffset (DoubleReg ILIT(2)) = OFFSET_Dbl2 +#ifdef OFFSET_Lng1 +baseRegOffset (LongReg _ ILIT(1)) = OFFSET_Lng1 +#endif +#ifdef OFFSET_Lng2 +baseRegOffset (LongReg _ ILIT(2)) = OFFSET_Lng2 +#endif baseRegOffset TagReg = OFFSET_Tag baseRegOffset RetReg = OFFSET_Ret baseRegOffset SpA = OFFSET_SpA @@ -665,6 +671,12 @@ callerSaves (DoubleReg ILIT(1)) = True #ifdef CALLER_SAVES_DblReg2 callerSaves (DoubleReg ILIT(2)) = True #endif +#ifdef CALLER_SAVES_LngReg1 +callerSaves (LongReg _ ILIT(1)) = True +#endif +#ifdef CALLER_SAVES_LngReg2 +callerSaves (LongReg _ ILIT(2)) = True +#endif #ifdef CALLER_SAVES_Tag callerSaves TagReg = True #endif @@ -752,6 +764,12 @@ magicIdRegMaybe (DoubleReg ILIT(1)) = Just (FixedReg ILIT(REG_Dbl1)) #ifdef REG_Dbl2 magicIdRegMaybe (DoubleReg ILIT(2)) = Just (FixedReg ILIT(REG_Dbl2)) #endif +#ifdef REG_Lng1 +magicIdRegMaybe (LongReg _ ILIT(1)) = Just (FixedReg ILIT(REG_Lng1)) +#endif +#ifdef REG_Lng2 +magicIdRegMaybe (LongReg _ ILIT(2)) = Just (FixedReg ILIT(REG_Lng2)) +#endif #ifdef REG_Tag magicIdRegMaybe TagReg = Just (FixedReg ILIT(REG_TagReg)) #endif diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 2e7e64c..5923b00 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -19,6 +19,7 @@ import Ratio ( Rational ) import AbsCSyn ( node, infoptr, MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) +import CallConv ( CallConv ) import CLabel ( mkAsmTempLabel, CLabel ) import PrimRep ( PrimRep ) import PrimOp ( PrimOp ) @@ -95,7 +96,7 @@ data StixTree -- Calls to C functions - | StCall FAST_STRING PrimRep [StixTree] + | StCall FAST_STRING CallConv PrimRep [StixTree] -- Assembly-language comments diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index 23c6a07..cd9a553 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -17,6 +17,7 @@ import MachMisc import MachRegs import AbsCSyn -- bits and bobs... +import CallConv ( cCallConv ) import Constants ( mIN_MP_INT_SIZE ) import Literal ( Literal(..) ) import OrdList ( OrdList ) @@ -45,9 +46,9 @@ argument2 = mpStruct 2 result2 = mpStruct 2 result3 = mpStruct 3 result4 = mpStruct 4 -init2 = StCall SLIT("mpz_init") VoidRep [result2] -init3 = StCall SLIT("mpz_init") VoidRep [result3] -init4 = StCall SLIT("mpz_init") VoidRep [result4] +init2 = StCall SLIT("mpz_init") cCallConv VoidRep [result2] +init3 = StCall SLIT("mpz_init") cCallConv VoidRep [result3] +init4 = StCall SLIT("mpz_init") cCallConv VoidRep [result4] gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) = let @@ -64,7 +65,7 @@ gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) safeHp = saveLoc Hp save = StAssign PtrRep safeHp oldHp (a1,a2,a3) = toStruct argument1 (aa,sa,da) - mpz_op = StCall rtn VoidRep [result2, argument1] + mpz_op = StCall rtn cCallConv VoidRep [result2, argument1] restore = StAssign PtrRep stgHp safeHp (r1,r2,r3) = fromStruct result2 (ar,sr,dr) in @@ -99,7 +100,7 @@ gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda save = StAssign PtrRep safeHp oldHp (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1) (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2) - mpz_op = StCall rtn VoidRep [result3, argument1, argument2] + mpz_op = StCall rtn cCallConv VoidRep [result3, argument1, argument2] restore = StAssign PtrRep stgHp safeHp (r1,r2,r3) = fromStruct result3 (ar,sr,dr) in @@ -140,7 +141,7 @@ gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2) save = StAssign PtrRep safeHp oldHp (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1) (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2) - mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2] + mpz_op = StCall rtn cCallConv VoidRep [result3, result4, argument1, argument2] restore = StAssign PtrRep stgHp safeHp (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1) (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2) @@ -181,7 +182,7 @@ gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize)) (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1) (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2) - mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2] + mpz_cmp = StCall SLIT("mpz_cmp") cCallConv IntRep [argument1, argument2] r1 = StAssign IntRep result mpz_cmp in returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs) @@ -204,7 +205,7 @@ gmpInteger2Int res args@(chp, caa,csa,cda) da = amodeToStix cda (a1,a2,a3) = toStruct hp (aa,sa,da) - mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp] + mpz_get_si = StCall SLIT("mpz_get_si") cCallConv IntRep [hp] r1 = StAssign IntRep result mpz_get_si in returnUs (\xs -> a1 : a2 : a3 : r1 : xs) @@ -223,7 +224,7 @@ gmpInteger2Word res args@(chp, caa,csa,cda) da = amodeToStix cda (a1,a2,a3) = toStruct hp (aa,sa,da) - mpz_get_ui = StCall SLIT("mpz_get_ui") IntRep [hp] + mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [hp] r1 = StAssign WordRep result mpz_get_ui in returnUs (\xs -> a1 : a2 : a3 : r1 : xs) @@ -305,11 +306,11 @@ gmpString2Integer res@(car,csr,cdr) (liveness, str) safeHp = saveLoc Hp save = StAssign PtrRep safeHp oldHp result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize))) - set_str = StCall SLIT("mpz_init_set_str") IntRep + set_str = StCall SLIT("mpz_init_set_str") cCallConv IntRep [result, amodeToStix str, StInt 10] test = StPrim IntEqOp [set_str, StInt 0] cjmp = StCondJump ulbl test - abort = StCall SLIT("abort") VoidRep [] + abort = StCall SLIT("abort") cCallConv VoidRep [] join = StLabel ulbl restore = StAssign PtrRep stgHp safeHp (a1,a2,a3) = fromStruct result (ar,sr,dr) @@ -346,7 +347,7 @@ encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon) FloatRep -> SLIT("__encodeFloat") DoubleRep -> SLIT("__encodeDouble") _ -> panic "encodeFloatingKind" - encode = StCall fn pk' [hp, expon] + encode = StCall fn cCallConv pk' [hp, expon] r1 = StAssign pk' result encode in returnUs (\xs -> a1 : a2 : a3 : r1 : xs) @@ -376,7 +377,7 @@ decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg) FloatRep -> SLIT("__decodeFloat") DoubleRep -> SLIT("__decodeDouble") _ -> panic "decodeFloatingKind" - decode = StCall fn VoidRep [mantissa, hp, arg] + decode = StCall fn cCallConv VoidRep [mantissa, hp, arg] (a1,a2,a3) = fromStruct mantissa (ar,sr,dr) a4 = StAssign IntRep exponr (StInd IntRep hp) in diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index ab0ecc4..3d1e564 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -12,6 +12,7 @@ import {-# SOURCE #-} StixPrim ( amodeToStix ) import MachMisc import MachRegs import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode ) +import CallConv ( cCallConv ) import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE, sTD_UF_SIZE ) @@ -284,7 +285,7 @@ heapCheck liveness words reenter cjmp = StCondJump ulbl test arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness] -- ToDo: Overflow? (JSM) - gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg] + gc = StCall SLIT("PerformGC_wrapper") cCallConv VoidRep [arg] join = StLabel ulbl in returnUs (\xs -> assign : cjmp : gc : join : xs) @@ -306,5 +307,5 @@ ind_info = sStLitLbl SLIT("Ind_info") updatePAP, stackOverflow :: StixTree updatePAP = StJump (sStLitLbl SLIT("UpdatePAP")) -stackOverflow = StCall SLIT("StackOverflow") VoidRep [] +stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep [] \end{code} diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 2b28c64..42c2bf9 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -13,6 +13,7 @@ import MachRegs import AbsCSyn import AbsCUtils ( getAmodeRep, mixedTypeLocn ) +import CallConv ( cCallConv ) import Constants ( spARelToInt, spBRelToInt ) import CostCentre ( noCostCentreAttached ) import HeapOffs ( hpRelToInt, subOff ) @@ -130,15 +131,14 @@ primCode [res] Word2IntOp [arg] \end{code} The @ErrorIO@ primitive is actually a bit weird...assign a new value -to the root closure, flush stdout and stderr, and jump to the -@ErrorIO_innards@. +to the root closure, and jump to the @ErrorIO_innards@. \begin{code} primCode [] ErrorIOPrimOp [rhs] = let changeTop = StAssign PtrRep topClosure (amodeToStix rhs) in - returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs) + returnUs (\xs -> changeTop : errorIO : xs) \end{code} @newArray#@ ops allocate heap space. @@ -152,7 +152,7 @@ primCode [res] NewArrayOp args loc = StIndex PtrRep stgHp (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]]) assign = StAssign PtrRep result loc - initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial] + initialise = StCall SLIT("newArrZh_init") cCallConv VoidRep [result, n, initial] in heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> @@ -318,7 +318,7 @@ primCode [lhs] DeRefStablePtrOp [sp] lhs' = amodeToStix lhs pk = getAmodeRep lhs sp' = amodeToStix sp - call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable] + call = StCall SLIT("deRefStablePointer") cCallConv pk [sp', smStablePtrTable] assign = StAssign pk lhs' call in returnUs (\xs -> assign : xs) @@ -439,21 +439,21 @@ primCode [lhs] SeqOp [a] lhs' = amodeToStix lhs a' = amodeToStix a pk = getAmodeRep lhs -- an IntRep - call = StCall SLIT("SeqZhCode") pk [a'] + call = StCall SLIT("SeqZhCode") cCallConv pk [a'] assign = StAssign pk lhs' call in -- trace "SeqOp" $ returnUs (\xs -> assign : xs) -primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs +primCode lhs (CCallOp (Just fn) is_asm may_gc cconv arg_tys result_ty) rhs | is_asm = error "ERROR: Native code generator can't handle casm" | otherwise = case lhs of - [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs) + [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs) [lhs] -> let lhs' = amodeToStix lhs pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep - call = StAssign pk lhs' (StCall fn pk args) + call = StAssign pk lhs' (StCall fn cconv pk args) in returnUs (\xs -> call : xs) where @@ -582,7 +582,7 @@ amodeToStix (CCharLike x) amodeToStix (CIntLike (CLit (MachInt i _))) = StPrim IntAddOp [intLikePtr, StInt off] where - off = toInteger intLikeSize * i + off = toInteger intLikeSize * toInteger i amodeToStix (CIntLike x) = StPrim IntAddOp [intLikePtr, off] @@ -597,7 +597,7 @@ amodeToStix (CLit core) MachChar c -> StInt (toInteger (ord c)) MachStr s -> StString s MachAddr a -> StInt a - MachInt i _ -> StInt i + MachInt i _ -> StInt (toInteger i) MachLitLit s _ -> StLitLit s MachFloat d -> StDouble d MachDouble d -> StDouble d @@ -643,10 +643,8 @@ charLike = sStLitLbl SLIT("CHARLIKE_closures") -- Trees for the ErrorIOPrimOp -topClosure, flushStdout, flushStderr, errorIO :: StixTree +topClosure, errorIO :: StixTree topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure")) -flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")] -flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")] errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards"))) \end{code}