-genCCall target dest_regs argsAndHints = do
- let
- args = map fst argsAndHints
- argcode_and_vregs <- mapM arg_to_int_vregs args
- let
- (argcodes, vregss) = unzip argcode_and_vregs
- n_argRegs = length allArgRegs
- n_argRegs_used = min (length vregs) n_argRegs
- vregs = concat vregss
- -- deal with static vs dynamic call targets
- callinsns <- (case target of
- CmmCallee (CmmLit (CmmLabel lbl)) conv -> do
- return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
- CmmCallee expr conv -> do
- (dyn_c, [dyn_r]) <- arg_to_int_vregs expr
- return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
- CmmPrim mop -> do
- (res, reduce) <- outOfLineFloatOp mop
- lblOrMopExpr <- case res of
- Left lbl -> do
- return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
- Right mopExpr -> do
- (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr
- return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
- if reduce then panic "genCCall(sparc): can not reduce" else return lblOrMopExpr
-
- )
- let
- argcode = concatOL argcodes
- (move_sp_down, move_sp_up)
- = let diff = length vregs - n_argRegs
- nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
- in if nn <= 0
- then (nilOL, nilOL)
- else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
- transfer_code
- = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
- return (argcode `appOL`
- move_sp_down `appOL`
- transfer_code `appOL`
- callinsns `appOL`
- unitOL NOP `appOL`
- move_sp_up)
- where
- -- move args from the integer vregs into which they have been
- -- marshalled, into %o0 .. %o5, and the rest onto the stack.
- move_final :: [Reg] -> [Reg] -> Int -> [Instr]
-
- move_final [] _ offset -- all args done
- = []
-
- move_final (v:vs) [] offset -- out of aregs; move to stack
- = ST I32 v (spRel offset)
- : move_final vs [] (offset+1)
-
- move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
- = OR False g0 (RIReg v) a
- : move_final vs az offset
-
- -- generate code to calculate an argument, and move it into one
- -- or two integer vregs.
- arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])
- arg_to_int_vregs arg
- | (cmmExprRep arg) == I64
- = do
- (ChildCode64 code r_lo) <- iselExpr64 arg
- let
- r_hi = getHiVRegFromLo r_lo
- return (code, [r_hi, r_lo])
- | otherwise
- = do
- (src, code) <- getSomeReg arg
- tmp <- getNewRegNat (cmmExprRep arg)
- let
- pk = cmmExprRep arg
- case pk of
- F64 -> do
- v1 <- getNewRegNat I32
- v2 <- getNewRegNat I32
- return (
- code `snocOL`
- FMOV F64 src f0 `snocOL`
- ST F32 f0 (spRel 16) `snocOL`
- LD I32 (spRel 16) v1 `snocOL`
- ST F32 (fPair f0) (spRel 16) `snocOL`
- LD I32 (spRel 16) v2
- ,
- [v1,v2]
- )
- F32 -> do
- v1 <- getNewRegNat I32
- return (
- code `snocOL`
- ST F32 src (spRel 16) `snocOL`
- LD I32 (spRel 16) v1
- ,
- [v1]
- )
- other -> do
- v1 <- getNewRegNat I32
- return (
- code `snocOL` OR False g0 (RIReg src) v1
- ,
- [v1]
- )
-outOfLineFloatOp mop =
- do
- dflags <- getDynFlagsNat
- mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $
- mkForeignLabel functionName Nothing True
- let mopLabelOrExpr = case mopExpr of
- CmmLit (CmmLabel lbl) -> Left lbl
- _ -> Right mopExpr
- return (mopLabelOrExpr, reduce)
- where
- (reduce, functionName) = case mop of
- MO_F32_Exp -> (True, FSLIT("exp"))
- MO_F32_Log -> (True, FSLIT("log"))
- MO_F32_Sqrt -> (True, FSLIT("sqrt"))