[start adding new c-- operator based representation
John Meacham <john@repetae.net>**20070523071542] hunk ./C/Arch.hs 2
-module C.Arch(determineArch,primitiveInfo,genericPrimitiveInfo) where
+module C.Arch(
+    ArchInfo(),
+    archGetPrimInfo,
+    archInfo,
+    archOpTy,
+    genericArchInfo,
+    determineArch,
+    primitiveInfo,
+    genericPrimitiveInfo
+    ) where
hunk ./C/Arch.hs 41
+import qualified C.Op as Op
hunk ./C/Arch.hs 49
+newtype ArchInfo = ArchInfo {
+    archPrimMap :: Map.Map ExtType PrimType
+}
+
hunk ./C/Arch.hs 67
-    ("x86_64",Just 32,arch_i686,["-m32"])
+    ("x86_64",Just (32::Int),arch_i686,["-m32"])
hunk ./C/Arch.hs 72
+-- get information on a primitive type if it is available
+archGetPrimInfo :: Monad m => ArchInfo -> ExtType -> m PrimType
+archGetPrimInfo ArchInfo { archPrimMap = pi } et = case Map.lookup et pi of
+    Nothing -> fail $ "archGetPrimInfo: No info for: " ++ et
+    Just s -> return s
+
hunk ./C/Arch.hs 79
-primitiveInfo et = Map.lookup et primMap
+primitiveInfo et = archGetPrimInfo archInfo et
hunk ./C/Arch.hs 82
-genericPrimitiveInfo et = Map.lookup et primMap
+genericPrimitiveInfo et = archGetPrimInfo genericArchInfo et
hunk ./C/Arch.hs 84
+genericArchInfo = ArchInfo { archPrimMap = primMap }
+archInfo = ArchInfo { archPrimMap = primMap }
hunk ./C/Arch.hs 91
+archOpTy :: ArchInfo -> ExtType -> Op.Ty
+archOpTy ai s = case archGetPrimInfo ai s of
+    Nothing -> Op.TyBits (Op.BitsExt s) Op.HintNone
+    Just pt -> case primTypeType pt of
+        PrimTypeIntegral -> Op.TyBits (Op.Bits $ 8 * primTypeSizeOf pt) (if primTypeIsSigned pt then Op.HintSigned else Op.HintUnsigned)
+        PrimTypeFloating ->  Op.TyBits (Op.Bits $ 8 * primTypeSizeOf pt) Op.HintFloat
+        _ -> Op.TyBits (Op.BitsExt s) Op.HintNone
+
+
hunk ./C/Arch.hs 121
-            (_,"x86_64",64) -> ("x86_64",arch_x86_64,[])
+            (_,"x86_64",(64::Int)) -> ("x86_64",arch_x86_64,[])
addfile ./C/Op.hs
hunk ./C/Op.hs 1
+module C.Op where
+
+import Data.Binary
+
+{-
+
+Basic operations. These are chosen to be roughly equivalent to c-- operations,
+but can be effectively used to generate C or assembly code as well.
+
+An operation consists of the operation itself, the type of the arguments and
+return value, and a hint attached to each argument.
+
+A condition is that the operation must be fully determined by the operation
+name and the type of its arguments. this specifically does not include the
+hint. For instance, since whether a number is signed or unsigned is in the
+hint, so the operation itself must say whether it is signed or unsigned.
+
+Also, distinct algorithms should be given different operations, for instance
+floating point and integer comparison are so different that they should be
+separate opcodes, even if it could be determined by the type they operate on.
+
+-}
+
+
+
+-- these take 2 arguments of the same type, and return one of the same type.
+-- an exception are the mulx routines, which may return a type exactly
+-- double in size of the original, and the shift and rotate routines, where the
+-- second argument may be of any width and is interpreted as an unsigned
+-- number.
+--
+-- the invarient is that the return type is always exactly determined by the
+-- argument types
+
+
+data BinOp
+    = Add
+    | Sub
+
+    | Mul
+    | Mulx
+    | UMulx
+
+    | Div   -- ^ round to -Infinity
+    | Mod   -- ^ mod rounding to -Infinity
+
+    | Quot  -- ^ round to 0
+    | Rem   -- ^ rem rounding to 0
+
+    | UDiv  -- ^ round to zero (unsigned)
+    | Modu  -- ^ unsigned mod
+
+    -- bitwise
+    | And
+    | Or
+    | Xor
+    | Not
+    | Shl
+    | Shr    -- ^ shift right logical
+    | Shra   -- ^ shift right arithmetic
+    | Rotl
+    | Rotr
+    -- floating
+    | FAdd
+    | FSub
+    | FDiv
+    | FMul
+    | FPwr
+    | FAtan2
+
+    -- These all compare two things of the same type, and return a boolean.
+    | Eq
+    | NEq
+    | Gt
+    | Gte
+    | Lt
+    | Lte
+    -- unsigned versions
+    | UGt
+    | UGte
+    | ULt
+    | ULte
+
+    -- floating point comparasons
+    | FEq
+    | FNEq
+    | FGt
+    | FGte
+    | FLt
+    | FLte
+    -- whether two values can be compared at all.
+    | FOrdered
+    deriving(Eq,Show,Ord)
+    {-! derive: Binary !-}
+
+data UnOp
+    = Neg   -- ^ 2s compliment negation
+    | Com   -- ^ bitwise compliment
+    -- floating
+    | FAbs  -- ^ floating absolute value
+    | Sin
+    | Cos
+    | Tan
+    | Sinh
+    | Cosh
+    | Tanh
+    | Asin
+    | Acos
+    | Atan
+    | Log
+    | Exp
+    | Sqrt
+    deriving(Eq,Show,Ord)
+    {-! derive: Binary !-}
+
+
+-- conversion ops always are NOPs and can be omitted when
+-- the initial and target types are the same when the hint is ignored.
+
+data ConvOp
+    = F2I
+    | F2U
+    | U2F
+    | I2F
+    | Lobits
+    | Sx
+    | Zx
+    -- these should only be used when the
+    -- size of the concrete types is not
+    -- known. so you don't know whether
+    -- to extend or shrink the value
+    | I2I
+    | U2U
+    deriving(Eq,Show,Ord)
+    {-! derive: Binary !-}
+
+
+data ValOp
+    = NaN
+    | PInf
+    | NInf
+    | PZero
+    | NZero
+    deriving(Eq,Show,Ord)
+    {-! derive: Binary !-}
+
+
+data TyBits = Bits !Int | BitsPtr | BitsExt String
+    deriving(Eq,Show,Ord)
+    {-! derive: Binary !-}
+
+data TyHint
+    = HintSigned
+    | HintUnsigned
+    | HintFloat        -- an IEEE floating point value
+    | HintCharacter    -- a unicode character, implies unsigned
+    | HintNone         -- no hint
+    deriving(Eq,Show,Ord)
+    {-! derive: Binary !-}
+
+data Ty
+    = TyBits !TyBits !TyHint
+    | TyBool
+    deriving(Eq,Show,Ord)
+    {-! derive: Binary !-}
+
+data Op v
+    = BinOp BinOp v v
+    | UnOp UnOp v
+    | ValOp ValOp
+    deriving(Eq,Show,Ord)
+    {-! derive: Binary !-}
+
+
+binopType :: BinOp -> Ty -> Ty -> Ty
+binopType Mulx  (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h
+binopType UMulx (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h
+binopType Eq  _ _ =  TyBool
+binopType NEq _ _ =  TyBool
+binopType Gt  _ _ =  TyBool
+binopType Gte _ _ =  TyBool
+binopType Lt  _ _ =  TyBool
+binopType Lte _ _ =  TyBool
+binopType UGt  _ _ =  TyBool
+binopType UGte _ _ =  TyBool
+binopType ULt  _ _ =  TyBool
+binopType ULte _ _ =  TyBool
+binopType FEq  _ _ =  TyBool
+binopType FNEq _ _ =  TyBool
+binopType FGt  _ _ =  TyBool
+binopType FGte _ _ =  TyBool
+binopType FLt  _ _ =  TyBool
+binopType FLte _ _ =  TyBool
+binopType FOrdered _ _ =  TyBool
+binopType _ t1 _ = t1
+
+isCommutable :: BinOp -> Bool
+isCommutable x = f x where
+    f Add = True
+    f Mul = True
+    f And = True
+    f Or  = True
+    f Xor = True
+    f Eq  = True
+    f NEq = True
+    f FAdd = True
+    f FMul = True
+    f _ = False
+
+isAssociative :: BinOp -> Bool
+isAssociative x = f x where
+    f Add = True
+    f Mul = True
+    f And = True
+    f Or  = True
+    f Xor = True
+    f _ = False
+
+binopInfix :: BinOp -> Maybe (String,Int)
+binopInfix UDiv = Just ("/",8)
+binopInfix Mul  = Just ("*",8)
+binopInfix Modu = Just ("%",8)
+binopInfix Sub  = Just ("-",7)
+binopInfix Add  = Just ("+",7)
+binopInfix Shr  = Just (">>",6)
+binopInfix Shl  = Just ("<<",6)
+binopInfix And  = Just ("&",5)
+binopInfix Xor  = Just ("^",4)
+binopInfix Or   = Just ("|",3)
+binopInfix UGte = Just (">=",2)
+binopInfix UGt  = Just (">",2)
+binopInfix ULte = Just ("<=",2)
+binopInfix ULt  = Just ("<",2)
+binopInfix Eq   = Just ("==",2)
+binopInfix NEq  = Just ("!=",2)
+binopInfix _ = Nothing
+
+class IsOperator o where
+    isCheap :: o -> Bool
+    isEagerSafe :: o -> Bool
+
+
+instance IsOperator BinOp where
+    isCheap FAtan2 = False
+    isCheap _ = True
+
+    isEagerSafe Div = False
+    isEagerSafe Mod = False
+    isEagerSafe Quot = False
+    isEagerSafe Rem  = False
+    isEagerSafe UDiv = False
+    isEagerSafe Modu = False
+    isEagerSafe _ = True
+
+
+instance IsOperator UnOp where
+    isCheap _ = True
+    isEagerSafe _ = True
+
+
+instance IsOperator ConvOp where
+    isCheap _ = True
+    isEagerSafe _ = True
+
+
+instance IsOperator (Op v) where
+    isCheap (BinOp o _ _) = isCheap o
+    isCheap (UnOp o _) = isCheap o
+    isCheap _ = False
+    isEagerSafe (BinOp o _ _) = isEagerSafe o
+    isEagerSafe (UnOp o _) = isEagerSafe o
+    isEagerSafe _ = False
+
hunk ./Grin/Grin.hs 87
+import qualified C.Op as Op
hunk ./Grin/Grin.hs 212
+    | TyPrim Op.Ty             -- ^ a basic type
hunk ./Grin/Grin.hs 228
-createFuncDef local name body@(Tup args :-> rest)  = updateFuncDefProps FuncDef { funcDefName = name, funcDefBody = body, funcDefCall = call, funcDefProps = funcProps } where
+createFuncDef local name body@(~(Tup args) :-> rest)  = updateFuncDefProps FuncDef { funcDefName = name, funcDefBody = body, funcDefCall = call, funcDefProps = funcProps } where
hunk ./Grin/Grin.hs 232
-updateFuncDefProps fd@FuncDef { funcDefBody = body@(Tup args :-> rest) } =  fd { funcDefProps = props } where
+updateFuncDefProps fd@FuncDef { funcDefBody = body@(~(Tup args) :-> rest) } =  fd { funcDefProps = props } where
hunk ./Grin/Grin.hs 261
+    funcType = undefined,
hunk ./Grin/Grin.hs 277
+    show (TyPrim t) = show t
hunk ./Grin/Grin.hs 450
-    TyNode -> (NodeC tagHole [])
+    ty@(TyPrim _) -> (Lit 0 ty)
+    ~TyNode -> (NodeC tagHole [])
hunk ./Grin/Grin.hs 611
+    getType MkClosure { expType = ty } = ty
hunk ./Grin/Grin.hs 757
-valToItem (Tag _) = BasicValue TyTag
+valToItem ~(Tag _) = BasicValue TyTag
hunk ./Grin/Grin.hs 777
-combineItem (NodeValue ns1) (NodeValue ns2) = NodeValue ns where
+combineItem ~(NodeValue ns1) ~(NodeValue ns2) = NodeValue ns where