Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
  • 5 commits
  • 20 files changed
  • 0 commit comments
  • 1 contributor
5 Makefile.in
View
@@ -177,7 +177,8 @@ TEST_FILES := tests/Bc/Bc0016.lcbc tests/Bc/Bc0014.lcbc \
tests/Bc/MultiReturn.lcbc tests/Bc/MultiReturn2.lcbc \
tests/Bc/MultiReturn3.lcbc tests/Bc/MultiReturnJit.lcbc \
tests/Bc/UnpackCString.lcbc tests/Bc/Monoid.lcbc \
- tests/Bc/NopPrims.lcbc
+ tests/Bc/NopPrims.lcbc tests/Bc/NegateInt.lcbc \
+ tests/Bc/WordCompare.lcbc tests/Bc/TestShow.lcbc
lcvm: $(VM_SRCS:.cc=.o) vm/main.o
@echo "LINK $(filter %.o %.a, $^) => $@"
@@ -329,7 +330,7 @@ tests/%.lcbc: tests/%.hs
PRIM_MODULES_ghc-prim = GHC/Bool GHC/Types GHC/Ordering GHC/Tuple GHC/Unit
PRIM_MODULES_integer-gmp = GHC/Integer/Type GHC/Integer
PRIM_MODULES_base = GHC/Base GHC/Classes GHC/Num GHC/List \
- Control/Exception/Base GHC/Enum Data/Maybe Data/Monoid
+ Control/Exception/Base GHC/Enum Data/Maybe Data/Monoid GHC/Show
PRIM_MODULES = \
$(patsubst %,tests/ghc-prim/%.lcbc,$(PRIM_MODULES_ghc-prim)) \
8 compiler/Lambdachine/Ghc/CoreToBC.hs
View
@@ -1436,6 +1436,7 @@ primOpOther :: Ghc.PrimOp -> Maybe (PrimOp, [OpTy], OpTy)
primOpOther primop =
case primop of
Ghc.IndexOffAddrOp_Char -> Just (OpIndexOffAddrChar, [AddrTy, IntTy], CharTy)
+ Ghc.IntNegOp -> Just (OpNegateInt, [IntTy], IntTy)
-- these are all NOPs
Ghc.OrdOp -> Just (OpNop, [CharTy], IntTy)
Ghc.ChrOp -> Just (OpNop, [IntTy], CharTy)
@@ -1462,6 +1463,13 @@ isCondPrimOp primop =
Ghc.CharLtOp -> Just (CmpLt, CharTy)
Ghc.CharLeOp -> Just (CmpLe, CharTy)
+ Ghc.WordGtOp -> Just (CmpGt, WordTy)
+ Ghc.WordGeOp -> Just (CmpGe, WordTy)
+ Ghc.WordEqOp -> Just (CmpEq, WordTy)
+ Ghc.WordNeOp -> Just (CmpNe, WordTy)
+ Ghc.WordLtOp -> Just (CmpLt, WordTy)
+ Ghc.WordLeOp -> Just (CmpLe, WordTy)
+
_ -> Nothing
-- | View expression as n-ary application. The expression in function
2  compiler/Lambdachine/Grin/Bytecode.hs
View
@@ -121,6 +121,7 @@ type CmpOp = BinOp
data PrimOp
= OpIndexOffAddrChar
+ | OpNegateInt
| OpNop -- See Note "Primitive Nops"
deriving (Eq, Ord, Show)
@@ -269,6 +270,7 @@ instance Pretty BcRhs where
instance Pretty PrimOp where
ppr OpIndexOffAddrChar = text "indexCharOffAddr#"
+ ppr OpNegateInt = text "negateInt#"
ppr OpNop = text "nop"
instance Pretty OpTy where
66 compiler/Lambdachine/Serialise.hs
View
@@ -487,7 +487,7 @@ putLinearIns lit_ids new_addrs ins_id ins = case ins of
Lst Update ->
putIns (insAD opc_UPDATE 0 1)
Lst (CondBranch cond ty (BcReg r1 _) (BcReg r2 _) t1 t2)
- | ty == IntTy || ty == CharTy
+ | ty == IntTy || ty == CharTy || ty == WordTy
-> do
let (swap_targets, target)
| t1 == ins_id + 1 = (True, t2)
@@ -495,16 +495,9 @@ putLinearIns lit_ids new_addrs ins_id ins = case ins of
| otherwise = error "putLinearIns: CondBranch: No branch target adjacent"
cond' | swap_targets = invertCondition cond
| otherwise = cond
- condOpcode c = case c of
- CmpGt -> opc_ISGT
- CmpLe -> opc_ISLE
- CmpGe -> opc_ISGE
- CmpLt -> opc_ISLT
- CmpEq -> opc_ISEQ
- CmpNe -> opc_ISNE
next_ins_addr = (new_addrs IM.! ins_id) + 2
offs = (new_addrs IM.! target) - next_ins_addr
- putIns $ insAD (condOpcode cond') (i2b r1) (i2h r2)
+ putIns $ insAD (condOpcode ty cond') (i2b r1) (i2h r2)
putIns $ insAJ opc_JMP 0 offs
Mid (Assign (BcReg d _) (Move (BcReg s _))) | d == s ->
return () -- redundant move instruction
@@ -552,6 +545,27 @@ putLinearIns lit_ids new_addrs ins_id ins = case ins of
binOpOpcode IntTy OpDiv = opc_DIVRR
binOpOpcode IntTy OpRem = opc_REMRR
+ isSigned :: OpTy -> Bool
+ isSigned IntTy = True
+ isSigned CharTy = True
+ isSigned WordTy = False
+
+ condOpcode :: OpTy -> CmpOp -> Word8
+ condOpcode ty c | isSigned ty = case c of
+ CmpGt -> opc_ISGT
+ CmpLe -> opc_ISLE
+ CmpGe -> opc_ISGE
+ CmpLt -> opc_ISLT
+ CmpEq -> opc_ISEQ
+ CmpNe -> opc_ISNE
+ condOpcode ty c | otherwise = case c of
+ CmpGt -> opc_ISGTU
+ CmpLe -> opc_ISLEU
+ CmpGe -> opc_ISGEU
+ CmpLt -> opc_ISLTU
+ CmpEq -> opc_ISEQ
+ CmpNe -> opc_ISNE
+
-- | Encode a case instruction.
--
-- Assumes that the default case is fall-through.
@@ -941,7 +955,7 @@ emitLinearIns bit_r lit_ids tgt_labels r ins_id ins = do
Lst Update ->
emitInsAD r opc_UPDATE 0 1
Lst (CondBranch cond ty (BcReg r1 _) (BcReg r2 _) t1 t2)
- | ty == IntTy || ty == CharTy
+ | ty == IntTy || ty == CharTy || ty == WordTy
-> do
let (swap_targets, target)
| t1 == ins_id + 1 = (True, t2)
@@ -950,14 +964,7 @@ emitLinearIns bit_r lit_ids tgt_labels r ins_id ins = do
error "emitLinearIns: CondBranch: No branch target adjacent"
cond' | swap_targets = invertCondition cond
| otherwise = cond
- condOpcode c = case c of
- CmpGt -> opc_ISGT
- CmpLe -> opc_ISLE
- CmpGe -> opc_ISGE
- CmpLt -> opc_ISLT
- CmpEq -> opc_ISEQ
- CmpNe -> opc_ISNE
- emitInsAD r (condOpcode cond') (i2b r1) (i2h r2)
+ emitInsAD r (condOpcode ty cond') (i2b r1) (i2h r2)
emitInsAJ r opc_JMP 0 (tgt_labels IM.! target)
Mid (Assign (BcReg d _) (Move (BcReg s _))) | d == s ->
return () -- redundant move instruction
@@ -998,6 +1005,8 @@ emitLinearIns bit_r lit_ids tgt_labels r ins_id ins = do
Mid (Assign (BcReg dst _)
(PrimOp OpIndexOffAddrChar _ty [BcReg ptr _, BcReg ofs _])) ->
emitInsABC r opc_PTROFSC (i2b dst) (i2b ptr) (i2b ofs)
+ Mid (Assign (BcReg dst _) (PrimOp OpNegateInt _ty [BcReg src _])) ->
+ emitInsAD r opc_NEG (i2b dst) (i2h src)
Mid (Store (BcReg ptr _) offs (BcReg src _)) | offs <= 255 ->
emitInsABC r opc_INITF (i2b ptr) (i2b src) (i2b offs)
Mid m -> error $ "Don't know how to serialise " ++ pretty m
@@ -1010,6 +1019,27 @@ emitLinearIns bit_r lit_ids tgt_labels r ins_id ins = do
binOpOpcode IntTy OpDiv = opc_DIVRR
binOpOpcode IntTy OpRem = opc_REMRR
+ isSigned :: OpTy -> Bool
+ isSigned IntTy = True
+ isSigned CharTy = True
+ isSigned WordTy = False
+
+ condOpcode :: OpTy -> CmpOp -> Word8
+ condOpcode ty c | isSigned ty = case c of
+ CmpGt -> opc_ISGT
+ CmpLe -> opc_ISLE
+ CmpGe -> opc_ISGE
+ CmpLt -> opc_ISLT
+ CmpEq -> opc_ISEQ
+ CmpNe -> opc_ISNE
+ condOpcode ty c | otherwise = case c of
+ CmpGt -> opc_ISGTU
+ CmpLe -> opc_ISLEU
+ CmpGe -> opc_ISGEU
+ CmpLt -> opc_ISLTU
+ CmpEq -> opc_ISEQ
+ CmpNe -> opc_ISNE
+
-- | A call like
--
-- > putArgs (map BcReg [1..6])
12 tests/Bc/NegateInt.hs
View
@@ -0,0 +1,12 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples, BangPatterns #-}
+module Bc.NegateInt where
+
+import GHC.Base
+import GHC.Prim
+import GHC.Num
+
+loop :: Int# -> Int# -> Int
+loop 0# x = I# x
+loop n x = loop (n -# 1#) (negateInt# x)
+
+test = loop 51# 4# == -4
12 tests/Bc/TestShow.hs
View
@@ -0,0 +1,12 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples, BangPatterns #-}
+module Bc.TestShow where
+
+import GHC.Base
+import GHC.Show
+import GHC.Num
+
+data Tree a = Leaf a | Branch (Tree a) (Tree a)
+ deriving (Eq, Show)
+
+test = show (Branch (Leaf (-5)) (Branch (Leaf (6 :: Int)) (Leaf 7))) ==
+ "Branch (Leaf (-5)) (Branch (Leaf 6) (Leaf 7))"
18 tests/Bc/WordCompare.hs
View
@@ -0,0 +1,18 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples, BangPatterns #-}
+module Bc.WordCompare where
+
+import GHC.Prim
+import GHC.Base
+
+loop :: Word# -> Int# -> Int#
+loop n x =
+ if n `leWord#` int2Word# 5#
+-- if word2Int# n <=# 5#
+ then x
+ else loop (int2Word# (word2Int# n +# 1#))
+ (x +# 1#)
+
+run :: Int# -> Bool
+run n = loop (int2Word# (0# -# n)) 0# ==# n
+
+test = run 10#
22 tests/base/GHC/Base.hs
View
@@ -14,6 +14,7 @@ import GHC.Types
import GHC.Bool
import GHC.Classes
import GHC.Ordering
+import {-# SOURCE #-} GHC.Show
import GHC.Tuple ()
import GHC.Unit ()
@@ -144,7 +145,7 @@ plusInt, minusInt, timesInt, modInt :: Int -> Int -> Int
-- XXX: Not quite correct, might overflow
negateInt :: Int -> Int
-negateInt (I# n) = I# (0# -# n)
+negateInt (I# n) = I# (negateInt# n)
modInt# :: Int# -> Int# -> Int#
x# `modInt#` y#
@@ -203,11 +204,20 @@ build g = g k []
where k x xs = x : xs
{-# NOINLINE k #-}
--- chr :: Int -> Char
--- chr i@(I# i#)
--- | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)
--- | otherwise
--- = error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")
+
+chr :: Int -> Char
+chr i@(I# i#)
+ | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)
+ | otherwise
+ = error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")
+
+
+unsafeChr :: Int -> Char
+unsafeChr (I# i#) = C# (chr# i#)
+
+-- | The 'Prelude.fromEnum' method restricted to the type 'Data.Char.Char'.
+ord :: Char -> Int
+ord (C# c#) = I# (ord# c#)
-- This code is needed for virtually all programs, since it's used for
-- unpacking the strings of error messages.
250 tests/base/GHC/Show.hs
View
@@ -0,0 +1,250 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Show
+-- Copyright : (c) The University of Glasgow, 1992-2002
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC Extensions)
+--
+-- The 'Show' class, and related operations.
+--
+-----------------------------------------------------------------------------
+
+-- #hide
+module GHC.Show
+ (
+ Show(..), ShowS,
+
+ -- Instances for Show: (), [], Bool, Ordering, Int, Char
+
+ -- Show support code
+ shows, showChar, showString, showParen, showList__, showSpace,
+ showLitChar, protectEsc,
+ intToDigit, showSignedInt,
+ appPrec, appPrec1,
+
+ -- Character operations
+ asciiTab,
+ )
+ where
+
+import GHC.Base
+import Data.Maybe
+import GHC.List ((!!), foldr1)
+
+type ShowS = String -> String
+
+class Show a where
+ -- | Convert a value to a readable 'String'.
+ --
+ -- 'showsPrec' should satisfy the law
+ --
+ -- > showsPrec d x r ++ s == showsPrec d x (r ++ s)
+ --
+ -- Derived instances of 'Text.Read.Read' and 'Show' satisfy the following:
+ --
+ -- * @(x,\"\")@ is an element of
+ -- @('Text.Read.readsPrec' d ('showsPrec' d x \"\"))@.
+ --
+ -- That is, 'Text.Read.readsPrec' parses the string produced by
+ -- 'showsPrec', and delivers the value that 'showsPrec' started with.
+
+ showsPrec :: Int -- ^ the operator precedence of the enclosing
+ -- context (a number from @0@ to @11@).
+ -- Function application has precedence @10@.
+ -> a -- ^ the value to be converted to a 'String'
+ -> ShowS
+
+ -- | A specialised variant of 'showsPrec', using precedence context
+ -- zero, and returning an ordinary 'String'.
+ show :: a -> String
+
+ -- | The method 'showList' is provided to allow the programmer to
+ -- give a specialised way of showing lists of values.
+ -- For example, this is used by the predefined 'Show' instance of
+ -- the 'Char' type, where values of type 'String' should be shown
+ -- in double quotes, rather than between square brackets.
+ showList :: [a] -> ShowS
+
+ showsPrec _ x s = show x ++ s
+ show x = shows x ""
+ showList ls s = showList__ shows ls s
+
+showList__ :: (a -> ShowS) -> [a] -> ShowS
+showList__ _ [] s = "[]" ++ s
+showList__ showx (x:xs) s = '[' : showx x (showl xs)
+ where
+ showl [] = ']' : s
+ showl (y:ys) = ',' : showx y (showl ys)
+
+appPrec, appPrec1 :: Int
+ -- Use unboxed stuff because we don't have overloaded numerics yet
+appPrec = I# 10# -- Precedence of application:
+ -- one more than the maximum operator precedence of 9
+appPrec1 = I# 11# -- appPrec + 1
+
+instance Show () where
+ showsPrec _ () = showString "()"
+
+instance Show a => Show [a] where
+ showsPrec _ = showList
+
+instance Show Bool where
+ showsPrec _ True = showString "True"
+ showsPrec _ False = showString "False"
+
+instance Show Ordering where
+ showsPrec _ LT = showString "LT"
+ showsPrec _ EQ = showString "EQ"
+ showsPrec _ GT = showString "GT"
+
+instance Show Char where
+ showsPrec _ '\'' = showString "'\\''"
+ showsPrec _ c = showChar '\'' . showLitChar c . showChar '\''
+
+ showList cs = showChar '"' . showl cs
+ where showl "" s = showChar '"' s
+ showl ('"':xs) s = showString "\\\"" (showl xs s)
+ showl (x:xs) s = showLitChar x (showl xs s)
+ -- Making 's' an explicit parameter makes it clear to GHC
+ -- that showl has arity 2, which avoids it allocating an extra lambda
+ -- The sticking point is the recursive call to (showl xs), which
+ -- it can't figure out would be ok with arity 2.
+
+instance Show Int where
+ showsPrec = showSignedInt
+
+instance Show a => Show (Maybe a) where
+ showsPrec _p Nothing s = showString "Nothing" s
+ showsPrec p (Just x) s
+ = (showParen (p > appPrec) $
+ showString "Just " .
+ showsPrec appPrec1 x) s
+
+instance (Show a, Show b) => Show (a,b) where
+ showsPrec _ (a,b) s = show_tuple [shows a, shows b] s
+
+instance (Show a, Show b, Show c) => Show (a, b, c) where
+ showsPrec _ (a,b,c) s = show_tuple [shows a, shows b, shows c] s
+
+instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
+ showsPrec _ (a,b,c,d) s = show_tuple [shows a, shows b, shows c, shows d] s
+
+instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where
+ showsPrec _ (a,b,c,d,e) s = show_tuple [shows a, shows b, shows c, shows d, shows e] s
+
+instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a,b,c,d,e,f) where
+ showsPrec _ (a,b,c,d,e,f) s = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f] s
+
+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g)
+ => Show (a,b,c,d,e,f,g) where
+ showsPrec _ (a,b,c,d,e,f,g) s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] s
+
+instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h)
+ => Show (a,b,c,d,e,f,g,h) where
+ showsPrec _ (a,b,c,d,e,f,g,h) s
+ = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h] s
+
+-- TODO: instances for N-tuples with N > 8
+
+show_tuple :: [ShowS] -> ShowS
+show_tuple ss = showChar '('
+ . foldr1 (\s r -> s . showChar ',' . r) ss
+ . showChar ')'
+
+shows :: (Show a) => a -> ShowS
+shows = showsPrec zeroInt
+
+-- | utility function converting a 'Char' to a show function that
+-- simply prepends the character unchanged.
+showChar :: Char -> ShowS
+showChar c = (c:)
+
+-- | utility function converting a 'String' to a show function that
+-- simply prepends the string unchanged.
+showString :: String -> ShowS
+showString s = (s++)
+
+-- | utility function that surrounds the inner show function with
+-- parentheses when the 'Bool' parameter is 'True'.
+showParen :: Bool -> ShowS -> ShowS
+showParen b p = if b then showChar '(' . p . showChar ')' else p
+
+showSpace :: ShowS
+showSpace = {-showChar ' '-} \ xs -> ' ' : xs
+
+-- | Convert a character to a string using only printable characters,
+-- using Haskell source-language escape conventions. For example:
+--
+-- > showLitChar '\n' s = "\\n" ++ s
+--
+showLitChar :: Char -> ShowS
+showLitChar c s | c > '\DEL' = showChar '\\' (protectEsc isDec (shows (ord c)) s)
+showLitChar '\DEL' s = showString "\\DEL" s
+showLitChar '\\' s = showString "\\\\" s
+showLitChar c s | c >= ' ' = showChar c s
+showLitChar '\a' s = showString "\\a" s
+showLitChar '\b' s = showString "\\b" s
+showLitChar '\f' s = showString "\\f" s
+showLitChar '\n' s = showString "\\n" s
+showLitChar '\r' s = showString "\\r" s
+showLitChar '\t' s = showString "\\t" s
+showLitChar '\v' s = showString "\\v" s
+showLitChar '\SO' s = protectEsc (== 'H') (showString "\\SO") s
+showLitChar c s = showString ('\\' : asciiTab!!ord c) s
+ -- I've done manual eta-expansion here, becuase otherwise it's
+ -- impossible to stop (asciiTab!!ord) getting floated out as an MFE
+
+isDec :: Char -> Bool
+isDec c = c >= '0' && c <= '9'
+
+protectEsc :: (Char -> Bool) -> ShowS -> ShowS
+protectEsc p f = f . cont
+ where cont s@(c:_) | p c = "\\&" ++ s
+ cont s = s
+
+
+asciiTab :: [String]
+asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ')
+ ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
+ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
+ "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
+ "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
+ "SP"]
+
+intToDigit :: Int -> Char
+intToDigit (I# i)
+ | i >=# 0# && i <=# 9# = unsafeChr (ord '0' `plusInt` I# i)
+ | i >=# 10# && i <=# 15# = unsafeChr (ord 'a' `minusInt` ten `plusInt` I# i)
+ | otherwise = error ("Char.intToDigit: not a digit " ++ show (I# i))
+
+ten :: Int
+ten = I# 10#
+
+showSignedInt :: Int -> Int -> ShowS
+showSignedInt (I# p) (I# n) r
+ | n <# 0# && p ># 6# = '(' : itos n (')' : r)
+ | otherwise = itos n r
+
+itos :: Int# -> String -> String
+itos n# cs
+ | n# <# 0# =
+ let !(I# minInt#) = minInt in
+ if n# ==# minInt#
+ -- negateInt# minInt overflows, so we can't do that:
+ then '-' : itos' (negateInt# (n# `quotInt#` 10#))
+ (itos' (negateInt# (n# `remInt#` 10#)) cs)
+ else '-' : itos' (negateInt# n#) cs
+ | otherwise = itos' n# cs
+ where
+ itos' :: Int# -> String -> String
+ itos' x# cs'
+ | x# <# 10# = C# (chr# (ord# '0'# +# x#)) : cs'
+ | otherwise = case chr# (ord# '0'# +# (x# `remInt#` 10#)) of { c# ->
+ itos' (x# `quotInt#` 10#) (C# c# : cs') }
+
7 tests/base/GHC/Show.hs-boot
View
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+
+module GHC.Show (showSignedInt) where
+
+import GHC.Types
+
+showSignedInt :: Int -> Int -> [Char] -> [Char]
21 vm/assembler.cc
View
@@ -660,6 +660,12 @@ void Assembler::intArith(IR *ins, x86Arith xa) {
allocLeft(dest, lref);
}
+void Assembler::intNegNot(IR *ins, x86Group3 xg) {
+ Reg dest = destReg(ins, kGPR);
+ emit_rr(XO_GROUP3, REX_64 | xg, dest);
+ allocLeft(dest, ins->op1());
+}
+
void Assembler::divmod(IR *ins, DivModOp op, bool useSigned) {
if (!useSigned) {
cerr << "NYI: Unsigned DIV/MOD." << endl;
@@ -1196,6 +1202,10 @@ void Assembler::emit(IR *ins) {
LC_ASSERT(isIntegerType(ins->type()));
divmod(ins, DIVMOD_MOD, isSigned(ins->type()));
break;
+ case IR::kNEG:
+ LC_ASSERT(isIntegerType(ins->type()));
+ intNegNot(ins, XOg_NEG);
+ break;
case IR::kSAVE:
save(ins);
break;
@@ -1212,6 +1222,17 @@ void Assembler::emit(IR *ins) {
compare(ins, asm_compmap[idx] & 15);
break;
}
+ case IR::kLTU:
+ case IR::kGEU:
+ case IR::kLEU:
+ case IR::kGTU: {
+ int idx = (int)ins->opcode() - (int)IR::kLTU;
+ LC_ASSERT(idx >= 0 && idx < countof(asm_compmap));
+ LC_ASSERT(buf_->snap(snapno_).ref() == curins_);
+ LC_ASSERT(ir(curins_) == ins);
+ compare(ins, (asm_compmap[idx] >> 4) & 15);
+ break;
+ }
case IR::kEQINFO:
itblGuard(ins);
break;
1  vm/assembler.hh
View
@@ -517,6 +517,7 @@ public:
bool is32BitLiteral(IRRef ref, int32_t *k);
void intArith(IR *ins, x86Arith xa);
+ void intNegNot(IR *ins, x86Group3 xg);
typedef uint32_t DivModOp;
enum {
5 vm/bytecode.hh
View
@@ -14,6 +14,11 @@ _START_LAMBDACHINE_NAMESPACE
_(ISGT, RRJ) \
_(ISEQ, RRJ) \
_(ISNE, RRJ) \
+ /* Unsigned comparisons, order significant */ \
+ _(ISLTU, RRJ) \
+ _(ISGEU, RRJ) \
+ _(ISLEU, RRJ) \
+ _(ISGTU, RRJ) \
/* Unary ops */ \
_(NOT, RR) \
_(NEG, RR) \
37 vm/capability.cc
View
@@ -321,6 +321,34 @@ record: {
pc += (pc - 1)->j();
DISPATCH_NEXT;
+op_ISLTU:
+ DECODE_AD;
+ ++pc;
+ if ((Word)base[opA] < (Word)base[opC])
+ pc += (pc - 1)->j();
+ DISPATCH_NEXT;
+
+op_ISGEU:
+ DECODE_AD;
+ ++pc;
+ if ((Word)base[opA] >= (Word)base[opC])
+ pc += (pc - 1)->j();
+ DISPATCH_NEXT;
+
+op_ISLEU:
+ DECODE_AD;
+ ++pc;
+ if ((Word)base[opA] <= (Word)base[opC])
+ pc += (pc - 1)->j();
+ DISPATCH_NEXT;
+
+op_ISGTU:
+ DECODE_AD;
+ ++pc;
+ if ((Word)base[opA] > (Word)base[opC])
+ pc += (pc - 1)->j();
+ DISPATCH_NEXT;
+
op_ISEQ:
DECODE_AD;
++pc;
@@ -627,6 +655,10 @@ op_CALL: {
fnode = (Closure *)base[opA];
top = T->top();
+ while (fnode->isIndirection()) {
+ fnode = (Closure *)fnode->payload(0);
+ }
+
LC_ASSERT(fnode != NULL);
LC_ASSERT(mm_->looksLikeClosure(fnode));
LC_ASSERT(callargs < BcIns::kMaxCallArgs);
@@ -679,6 +711,11 @@ op_CALLT: {
LC_ASSERT(fnode != NULL);
LC_ASSERT(mm_->looksLikeClosure(fnode));
LC_ASSERT(callargs < BcIns::kMaxCallArgs);
+
+ while (fnode->isIndirection()) {
+ fnode = (Closure *)fnode->payload(0);
+ }
+
LC_ASSERT(fnode->info()->type() == FUN ||
fnode->info()->type() == CAF ||
fnode->info()->type() == THUNK ||
3  vm/common.hh
View
@@ -350,7 +350,8 @@ typedef Word BloomFilter;
_(TRACE_TRUNCATE, "Trace truncation due to inner loop.") \
_(RECORD_CREATE_PAP, "Recording of call which creates a PAP.") \
_(RECORD_CALL_PAP, "Recording of a call of a PAP.") \
- _(RECORD_CALL_THUNK, "Recording of call of a thunk/CAF.")
+ _(RECORD_CALL_THUNK, "Recording of call of a thunk/CAF.") \
+ _(RECORD_CALL_IND, "Recording of call of an indirection.")
enum {
#define NYIENUM(name, descr) NYI_##name,
8 vm/ir.hh
View
@@ -40,6 +40,10 @@ typedef u4 IRRef; /* Used to pass around references */
_(GT, G, ref, ref) \
_(EQ, G, ref, ref) \
_(NE, G, ref, ref) \
+ _(LTU, G, ref, ref) \
+ _(GEU, G, ref, ref) \
+ _(LEU, G, ref, ref) \
+ _(GTU, G, ref, ref) \
_(EQRET, G, ref, ref) \
_(EQINFO, G, ref, ref) \
_(HEAPCHK, S, lit, ___) \
@@ -970,11 +974,15 @@ inline int IRBuffer::numFields(HeapEntry entry) {
// Can invert condition by toggling lowest bit.
LC_STATIC_ASSERT((IR::kLT ^ 1) == IR::kGE);
LC_STATIC_ASSERT((IR::kGT ^ 1) == IR::kLE);
+LC_STATIC_ASSERT((IR::kLTU ^ 1) == IR::kGEU);
+LC_STATIC_ASSERT((IR::kGTU ^ 1) == IR::kLEU);
LC_STATIC_ASSERT((IR::kEQ ^ 1) == IR::kNE);
// Order of comparison operations matters. Same is enforced for bytecode.
LC_STATIC_ASSERT((IR::kLT & 1) == 0);
LC_STATIC_ASSERT((IR::kLT + 2) == IR::kLE);
LC_STATIC_ASSERT((IR::kLE + 2) == IR::kEQ);
+LC_STATIC_ASSERT((IR::kLTU & 1) == 0);
+LC_STATIC_ASSERT((IR::kLTU + 2) == IR::kLEU);
_END_LAMBDACHINE_NAMESPACE
21 vm/jit.cc
View
@@ -226,6 +226,14 @@ static bool evalCond(BcIns::Opcode opc, Word left, Word right) {
return (WordInt)left == (WordInt)right;
case BcIns::kISNE:
return (WordInt)left != (WordInt)right;
+ case BcIns::kISLTU:
+ return (Word)left < (Word)right;
+ case BcIns::kISGEU:
+ return (Word)left >= (Word)right;
+ case BcIns::kISLEU:
+ return (Word)left <= (Word)right;
+ case BcIns::kISGTU:
+ return (Word)left > (Word)right;
default:
cerr << "FATAL: (REC) Cannot evaluate condition: " << (int)opc;
exit(2);
@@ -241,6 +249,9 @@ bool Jit::recordGenericApply(uint32_t call_info, Word *base,
case PAP:
logNYI(NYI_RECORD_CALL_PAP);
return false;
+ case IND:
+ logNYI(NYI_RECORD_CALL_IND);
+ return false;
case THUNK:
case CAF:
logNYI(NYI_RECORD_CALL_THUNK);
@@ -356,6 +367,10 @@ bool Jit::recordIns(BcIns *ins, Word *base, const Code *code) {
case BcIns::kISLT:
case BcIns::kISGE:
case BcIns::kISLE:
+ case BcIns::kISGTU:
+ case BcIns::kISLTU:
+ case BcIns::kISGEU:
+ case BcIns::kISLEU:
case BcIns::kISEQ:
case BcIns::kISNE: {
bool taken = evalCond(ins->opcode(), base[ins->a()], base[ins->d()]);
@@ -402,6 +417,12 @@ bool Jit::recordIns(BcIns *ins, Word *base, const Code *code) {
buf_.setSlot(ins->a(), aref);
break;
}
+ case BcIns::kNEG: {
+ TRef dref = buf_.slot(ins->d());
+ TRef aref = buf_.emit(IR::kNEG, IRT_I64, dref, TRef());
+ buf_.setSlot(ins->a(), aref);
+ break;
+ }
case BcIns::kPTROFSC: {
TRef ptrref = buf_.slot(ins->b());
TRef ofsref = buf_.slot(ins->c());
30 vm/loader.cc
View
@@ -465,7 +465,7 @@ InfoTable *Loader::loadInfoTable(BytecodeFile &f,
FwdRefInfoTable *old_itbl =
static_cast<FwdRefInfoTable *>(infoTables_[itbl_name]);
- if (old_itbl && old_itbl->type() != INVALID_OBJECT) {
+ if (isFullyLoadedInfoTable(old_itbl)) {
fprintf(stderr, "ERROR: Duplicate info table: %s\n", itbl_name);
exit(1);
}
@@ -575,7 +575,7 @@ void Loader::loadLiteral(BytecodeFile &f,
break;
case LIT_INFO: {
const char *infoname = loadId(f, strings, ".");
- loadInfoTableReference(infoname, literal);
+ loadInfoTableReference(infoname, (InfoTable **)literal);
}
break;
default:
@@ -688,23 +688,23 @@ void Loader::fixClosureForwardReference(const char *name, Closure *cl) {
}
}
-void Loader::loadInfoTableReference(const char *name, Word *literal) {
+void Loader::loadInfoTableReference(const char *name, InfoTable **dest) {
InfoTable *info = infoTables_[name];
FwdRefInfoTable *info2;
if (info == NULL) {
// 1st forward ref
info2 = new FwdRefInfoTable();
info2->type_ = INVALID_OBJECT;
- info2->next = (void **)literal;
- *literal = (Word)NULL;
+ info2->next = (void **)dest;
+ *dest = (InfoTable *)NULL;
infoTables_[name] = info2;
} else if (info->type() == INVALID_OBJECT) {
// subsequent forward ref
info2 = (FwdRefInfoTable *)info;
- *literal = (Word)info2->next;
- info2->next = (void **)literal;
+ *dest = (InfoTable *)info2->next;
+ info2->next = (void **)dest;
} else {
- *literal = (Word)info;
+ *dest = info;
}
}
@@ -738,16 +738,20 @@ void Loader::loadClosure(BytecodeFile &f,
const char *itbl_name = loadId(f, strings, ".");
InfoTable *info = infoTables_[itbl_name];
- // Info tables must all be fully loaded by now.
- LC_ASSERT(info != NULL && info->type() != INVALID_OBJECT);
- LC_ASSERT((info->type() != CAF && payloadsize == info->size()) ||
- (info->type() == CAF && payloadsize == 2));
+ if (isFullyLoadedInfoTable(info)) {
+ // If we haven't loaded the info table yet we cannot check this.
+ // This can happen when loading recursive groups of modules.
+ LC_ASSERT((info->type() != CAF && payloadsize == info->size()) ||
+ (info->type() == CAF && payloadsize == 2));
+ }
Closure *cl = mm_->allocStaticClosure(payloadsize);
+ loadInfoTableReference(itbl_name, &cl->header_.info_);
+
// Fill in closure payload. May create forward references to the
// current closure.
- cl->setInfo(info);
+
for (u4 i = 0; i < payloadsize; i++) {
DLOG("Loading payload for: %s [%d]\n", clos_name, i);
u1 dummy;
7 vm/loader.hh
View
@@ -154,7 +154,8 @@ private:
void loadClosure(BytecodeFile &, const StringTabEntry *strings);
void loadClosureReference(const char *name, Word *literal /* out */);
void fixClosureForwardReference(const char *name, Closure *cl);
- void loadInfoTableReference(const char *name, Word *literal /* out */);
+ inline bool isFullyLoadedInfoTable(InfoTable *);
+ void loadInfoTableReference(const char *name, InfoTable **dest /* out */);
void fixInfoTableForwardReference(const char *name, InfoTable *info);
bool checkNoForwardRefs();
@@ -165,6 +166,10 @@ private:
BasePathEntry *basepaths_;
};
+inline bool Loader::isFullyLoadedInfoTable(InfoTable *info) {
+ return (info != NULL) && (info->type() != INVALID_OBJECT);
+}
+
_END_LAMBDACHINE_NAMESPACE
#endif /* _LOADER_H_ */
12 vm/unittest.cc
View
@@ -1105,6 +1105,18 @@ TEST_F(RunFileTest, NopPrims) {
run("Bc.NopPrims");
}
+TEST_F(RunFileTest, NegateInt) {
+ run("Bc.NegateInt");
+}
+
+TEST_F(RunFileTest, WordCompare) {
+ run("Bc.WordCompare");
+}
+
+TEST_F(RunFileTest, TestShow) {
+ run("Bc.TestShow");
+}
+
TEST(HotCounters, Simple) {
HotCounters counters(5);
BcIns pc[] = { BcIns::ad(BcIns::kFUNC, 3, 0) };

No commit comments for this range

Something went wrong with that request. Please try again.