0aa3fd6 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Beginnings of integer SIMD support (no backend yet)

0aa3fd6Benjamin Saunders13 years ago

idris.cabal+2−1

compare with master

unifiedsplit

@@ -272,7 +272,8 @@ Executable idris

272 haskeline>=0.7, split, directory,

273 containers, process, transformers, filepath,

274 directory, binary, bytestring, text, pretty,

275− language-java>=0.2.2, libffi, llvm-general==3.3.3.*

275+ language-java>=0.2.2, libffi, llvm-general==3.3.3.*,

276+ vector

276

277

277 Extensions: MultiParamTypeClasses, FunctionalDependencies,

278 Extensions: MultiParamTypeClasses, FunctionalDependencies,

278 FlexibleInstances, TemplateHaskell

279 FlexibleInstances, TemplateHaskell

src/Core/CaseTree.hs+14−8

@@ -228,17 +228,18 @@ toPat tc tms = evalState (mapM (\x -> toPat' x []) tms) []

228 toPat' (P (TCon t a) n _) args | tc

229 = do args' <- mapM (\x -> toPat' x []) args

230 return $ PCon n t args'

231+ toPat' (Constant (AType (ATInt ITNative))) []

231− toPat' (Constant IType) [] | tc = return $ PCon (UN "Int") 1 []

232+ | tc = return $ PCon (UN "Int") 1 []

232− toPat' (Constant FlType) [] | tc = return $ PCon (UN "Float") 2 []

233+ toPat' (Constant (AType ATFloat)) [] | tc = return $ PCon (UN "Float") 2 []

233 toPat' (Constant ChType) [] | tc = return $ PCon (UN "Char") 3 []

234 toPat' (Constant ChType) [] | tc = return $ PCon (UN "Char") 3 []

234 toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 []

235 toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 []

235 toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 []

236 toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 []

237+ toPat' (Constant (AType (ATInt ITBig))) []

236− toPat' (Constant BIType) [] | tc = return $ PCon (UN "Integer") 6 []

238+ | tc = return $ PCon (UN "Integer") 6 []

237− toPat' (Constant B8Type) [] | tc = return $ PCon (UN "Bits8") 7 []

239+ toPat' (Constant (AType (ATInt (ITFixed n)))) []

238− toPat' (Constant B16Type) [] | tc = return $ PCon (UN "Bits16") 8 []

240+ | tc = return $ PCon (UN (fixedN n)) (7 + fromEnum n) [] -- 7-10 inclusive

239− toPat' (Constant B32Type) [] | tc = return $ PCon (UN "Bits32") 9 []

241+ toPat' (Constant (AType (ATInt (ITVec ity count)))) []

240− toPat' (Constant B64Type) [] | tc = return $ PCon (UN "Bits64") 10 []

242+ | tc = return $ PCon (UN (fixedN ity)) ((fromEnum ity + 1) * 1000 + count) [] -- 1000-5000 inclusive

241−

242 toPat' (P Bound n _) [] = do ns <- get

243 toPat' (P Bound n _) [] = do ns <- get

243 if n `elem` ns

244 if n `elem` ns

244 then return PAny

245 then return PAny

@@ -248,6 +249,11 @@ toPat tc tms = evalState (mapM (\x -> toPat' x []) tms) []

248 toPat' (Constant x) [] = return $ PConst x

249 toPat' (Constant x) [] = return $ PConst x

249 toPat' _ _ = return PAny

250 toPat' _ _ = return PAny

250

251

252+ fixedN IT8 = "Bits8"

253+ fixedN IT16 = "Bits16"

254+ fixedN IT32 = "Bits32"

255+ fixedN IT64 = "Bits64"

256+

251

257

252data Partition = Cons [Clause]

258data Partition = Cons [Clause]

253 | Vars [Clause]

259 | Vars [Clause]

src/Core/Evaluate.hs+15−10

@@ -329,11 +329,16 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

329

330 findConst c [] = Nothing

331 findConst c (ConstCase c' v : xs) | c == c' = Just v

332− findConst IType (ConCase n 1 [] v : xs) = Just v

332+ findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v

333− findConst FlType (ConCase n 2 [] v : xs) = Just v

333+ findConst (AType ATFloat) (ConCase n 2 [] v : xs) = Just v

334 findConst ChType (ConCase n 3 [] v : xs) = Just v

335 findConst StrType (ConCase n 4 [] v : xs) = Just v

336− findConst PtrType (ConCase n 5 [] v : xs) = Just v

336+ findConst PtrType (ConCase n 5 [] v : xs) = Just v

337+ findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v

338+ findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs)

339+ | tag == 7 + fromEnum ity = Just v

340+ findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs)

341+ | tag == (fromEnum ity + 1) * 1000 + count = Just v

337 findConst c (_ : xs) = findConst c xs

342 findConst c (_ : xs) = findConst c xs

338

343

339 getValArgs tm = getValArgs' tm []

344 getValArgs tm = getValArgs' tm []

@@ -517,16 +522,16 @@ eval_hnf ctxt statics genv tm = ev [] tm where

517

522

518 findConst c [] = Nothing

523 findConst c [] = Nothing

519 findConst c (ConstCase c' v : xs) | c == c' = Just v

524 findConst c (ConstCase c' v : xs) | c == c' = Just v

520− findConst IType (ConCase n 1 [] v : xs) = Just v

525+ findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v

521− findConst FlType (ConCase n 2 [] v : xs) = Just v

526+ findConst (AType ATFloat) (ConCase n 2 [] v : xs) = Just v

522 findConst ChType (ConCase n 3 [] v : xs) = Just v

527 findConst ChType (ConCase n 3 [] v : xs) = Just v

523 findConst StrType (ConCase n 4 [] v : xs) = Just v

528 findConst StrType (ConCase n 4 [] v : xs) = Just v

524 findConst PtrType (ConCase n 5 [] v : xs) = Just v

529 findConst PtrType (ConCase n 5 [] v : xs) = Just v

525− findConst BIType (ConCase n 6 [] v : xs) = Just v

530+ findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v

526− findConst B8Type (ConCase n 7 [] v : xs) = Just v

531+ findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs)

527− findConst B16Type (ConCase n 8 [] v : xs) = Just v

532+ | tag == 7 + fromEnum ity = Just v

528− findConst B32Type (ConCase n 9 [] v : xs) = Just v

533+ findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs)

529− findConst B64Type (ConCase n 10 [] v : xs) = Just v

534+ | tag == (fromEnum ity + 1) * 1000 + count = Just v

530 findConst c (_ : xs) = findConst c xs

535 findConst c (_ : xs) = findConst c xs

531

536

532 getValArgs (HApp t env args) = (t, env, args)

537 getValArgs (HApp t env args) = (t, env, args)

src/Core/Execute.hs+26−23

@@ -3,9 +3,7 @@ module Core.Execute (execute) where

4import Idris.AbsSyntax

5import Idris.AbsSyntaxTree

6−import IRTS.Lang( IntTy(..)

6+import IRTS.Lang(FType(..))

7− , intTyToConst

8− , FType(..))

10import Idris.Primitives(Prim(..), primitives)

8import Idris.Primitives(Prim(..), primitives)

@@ -387,8 +385,7 @@ chooseAlt _ [] = Nothing

387idrisType :: FType -> ExecVal

385idrisType :: FType -> ExecVal

388idrisType FUnit = EP Ref unitTy EErased

386idrisType FUnit = EP Ref unitTy EErased

389idrisType ft = EConstant (idr ft)

387idrisType ft = EConstant (idr ft)

390− where idr (FInt ty) = intTyToConst ty

388+ where idr (FArith ty) = AType ty

391− idr FDouble = FlType

392 idr FChar = ChType

389 idr FChar = ChType

393 idr FString = StrType

390 idr FString = StrType

394 idr FPtr = PtrType

391 idr FPtr = PtrType

@@ -404,18 +401,24 @@ call (FFun name argTypes retType) args =

404 Just f -> do res <- call' f args retType

401 Just f -> do res <- call' f args retType

405 return . Just . ioWrap $ res

402 return . Just . ioWrap $ res

406 where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal

403 where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal

404+ call' (Fun _ h) args (FArith (ATInt ITNative)) = do

407− call' (Fun _ h) args (FInt ITNative) = do res <- execIO $ callFFI h retCInt (prepArgs args)

405+ res <- execIO $ callFFI h retCInt (prepArgs args)

408− return (EConstant (I (fromIntegral res)))

406+ return (EConstant (I (fromIntegral res)))

407+ call' (Fun _ h) args (FArith (ATInt (ITFixed IT8))) = do

409− call' (Fun _ h) args (FInt IT8) = do res <- execIO $ callFFI h retCChar (prepArgs args)

408+ res <- execIO $ callFFI h retCChar (prepArgs args)

410− return (EConstant (B8 (fromIntegral res)))

409+ return (EConstant (B8 (fromIntegral res)))

410+ call' (Fun _ h) args (FArith (ATInt (ITFixed IT16))) = do

411− call' (Fun _ h) args (FInt IT16) = do res <- execIO $ callFFI h retCWchar (prepArgs args)

411+ res <- execIO $ callFFI h retCWchar (prepArgs args)

412− return (EConstant (B16 (fromIntegral res)))

412+ return (EConstant (B16 (fromIntegral res)))

413+ call' (Fun _ h) args (FArith (ATInt (ITFixed IT32))) = do

413− call' (Fun _ h) args (FInt IT32) = do res <- execIO $ callFFI h retCInt (prepArgs args)

414+ res <- execIO $ callFFI h retCInt (prepArgs args)

414− return (EConstant (B32 (fromIntegral res)))

415+ return (EConstant (B32 (fromIntegral res)))

416+ call' (Fun _ h) args (FArith (ATInt (ITFixed IT64))) = do

415− call' (Fun _ h) args (FInt IT64) = do res <- execIO $ callFFI h retCLong (prepArgs args)

417+ res <- execIO $ callFFI h retCLong (prepArgs args)

416− return (EConstant (B64 (fromIntegral res)))

418+ return (EConstant (B64 (fromIntegral res)))

419+ call' (Fun _ h) args (FArith ATFloat) = do

417− call' (Fun _ h) args FDouble = do res <- execIO $ callFFI h retCDouble (prepArgs args)

420+ res <- execIO $ callFFI h retCDouble (prepArgs args)

418− return (EConstant (Fl (realToFrac res)))

421+ return (EConstant (Fl (realToFrac res)))

419 call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)

422 call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)

420 return (EConstant (Ch (castCCharToChar res)))

423 return (EConstant (Ch (castCCharToChar res)))

421 call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)

424 call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)

@@ -456,15 +459,15 @@ foreignFromTT t = case (unApplyV t) of

456getFTy :: ExecVal -> Maybe FType

459getFTy :: ExecVal -> Maybe FType

457getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

460getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

458 case intTy of

461 case intTy of

459− "ITNative" -> Just $ FInt ITNative

462+ "ITNative" -> Just (FArith (ATInt ITNative))

460− "IT8" -> Just $ FInt IT8

463+ "IT8" -> Just (FArith (ATInt (ITFixed IT8)))

461− "IT16" -> Just $ FInt IT16

464+ "IT16" -> Just (FArith (ATInt (ITFixed IT16)))

462− "IT32" -> Just $ FInt IT32

465+ "IT32" -> Just (FArith (ATInt (ITFixed IT32)))

463− "IT64" -> Just $ FInt IT64

466+ "IT64" -> Just (FArith (ATInt (ITFixed IT64)))

464 _ -> Nothing

467 _ -> Nothing

465getFTy (EP _ (UN t) _) =

468getFTy (EP _ (UN t) _) =

466 case t of

469 case t of

467− "FFloat" -> Just FDouble

470+ "FFloat" -> Just (FArith ATFloat)

468 "FChar" -> Just FChar

471 "FChar" -> Just FChar

469 "FString" -> Just FString

472 "FString" -> Just FString

470 "FPtr" -> Just FPtr

473 "FPtr" -> Just FPtr

src/Core/TT.hs+56−18

@@ -25,8 +25,11 @@ import Debug.Trace

25import qualified Data.Map as Map

26import Data.Char

27import Data.List

28+import Data.Vector.Unboxed (Vector)

29+import qualified Data.Vector.Unboxed as V

28import qualified Data.Binary as B

30import qualified Data.Binary as B

29import Data.Binary hiding (get, put)

31import Data.Binary hiding (get, put)

32+import Foreign.Storable (sizeOf)

31import Util.Pretty hiding (Str)

34import Util.Pretty hiding (Str)

@@ -274,12 +277,46 @@ addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a

274addAlist [] ctxt = ctxt

277addAlist [] ctxt = ctxt

275addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt)

278addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt)

276

279

277−data Const = I Int | BI Integer | Fl Double | Ch Char | Str String

280+data NativeTy = IT8 | IT16 | IT32 | IT64

281+ deriving (Show, Eq, Ord, Enum)

282+

283+instance Pretty NativeTy where

284+ pretty IT8 = text "Bits8"

285+ pretty IT16 = text "Bits16"

286+ pretty IT32 = text "Bits32"

287+ pretty IT64 = text "Bits64"

288+

289+data IntTy = ITFixed NativeTy | ITNative | ITBig

290+ | ITVec NativeTy Int

291+ deriving (Show, Eq, Ord)

292+

293+data ArithTy = ATInt IntTy | ATFloat -- TODO: Float vectors

294+ deriving (Show, Eq, Ord)

295+

296+instance Pretty ArithTy where

297+ pretty (ATInt ITNative) = text "Int"

298+ pretty (ATInt ITBig) = text "BigInt"

299+ pretty (ATInt (ITFixed n)) = pretty n

300+ pretty (ATInt (ITVec e c)) = pretty e <> text "x" <> (text . show $ c)

301+ pretty ATFloat = text "Float"

302+

303+nativeTyWidth :: NativeTy -> Int

304+nativeTyWidth IT8 = 8

305+nativeTyWidth IT16 = 16

306+nativeTyWidth IT32 = 32

307+nativeTyWidth IT64 = 64

308+

309+{-# DEPRECATED intTyWidth "Non-total function, use nativeTyWidth and appropriate casing" #-}

310+intTyWidth :: IntTy -> Int

311+intTyWidth (ITFixed n) = nativeTyWidth n

312+intTyWidth ITNative = 8 * sizeOf (0 :: Int)

313+intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width"

279

314

315+data Const = I Int | BI Integer | Fl Double | Ch Char | Str String

280 | B8 Word8 | B16 Word16 | B32 Word32 | B64 Word64

316 | B8 Word8 | B16 Word16 | B32 Word32 | B64 Word64

281− | B8Type | B16Type | B32Type | B64Type

317+ | B8V (Vector Word8) | B16V (Vector Word16)

282−

318+ | B32V (Vector Word32) | B64V (Vector Word64)

319+ | AType ArithTy | ChType | StrType

283 | PtrType | VoidType | Forgot

320 | PtrType | VoidType | Forgot

284 deriving (Eq, Ord)

321 deriving (Eq, Ord)

285{-!

322{-!

@@ -295,18 +332,12 @@ instance Pretty Const where

295 pretty (Fl f) = text . show $ f

332 pretty (Fl f) = text . show $ f

296 pretty (Ch c) = text . show $ c

333 pretty (Ch c) = text . show $ c

297 pretty (Str s) = text s

334 pretty (Str s) = text s

298− pretty IType = text "Int"

335+ pretty (AType a) = pretty a

299− pretty BIType = text "BigInt"

300− pretty FlType = text "Float"

301 pretty ChType = text "Char"

336 pretty ChType = text "Char"

302 pretty StrType = text "String"

337 pretty StrType = text "String"

303 pretty PtrType = text "Ptr"

338 pretty PtrType = text "Ptr"

304 pretty VoidType = text "Void"

339 pretty VoidType = text "Void"

305 pretty Forgot = text "Forgot"

340 pretty Forgot = text "Forgot"

306− pretty B8Type = text "Bits8"

307− pretty B16Type = text "Bits16"

308− pretty B32Type = text "Bits32"

309− pretty B64Type = text "Bits64"

310 pretty (B8 w) = text . show $ w

341 pretty (B8 w) = text . show $ w

311 pretty (B16 w) = text . show $ w

342 pretty (B16 w) = text . show $ w

312 pretty (B32 w) = text . show $ w

343 pretty (B32 w) = text . show $ w

@@ -728,6 +759,11 @@ type WkEnv = WkEnvTT Name

728instance (Eq n, Show n) => Show (TT n) where

759instance (Eq n, Show n) => Show (TT n) where

729 show t = showEnv [] t

760 show t = showEnv [] t

730

761

762+itBitsName IT8 = "Bits8"

763+itBitsName IT16 = "Bits16"

764+itBitsName IT32 = "Bits32"

765+itBitsName IT64 = "Bits64"

766+

731instance Show Const where

767instance Show Const where

732 show (I i) = show i

768 show (I i) = show i

733 show (BI i) = show i ++ "L"

769 show (BI i) = show i ++ "L"

@@ -738,16 +774,18 @@ instance Show Const where

738 show (B16 x) = show x

774 show (B16 x) = show x

739 show (B32 x) = show x

775 show (B32 x) = show x

740 show (B64 x) = show x

776 show (B64 x) = show x

741− show IType = "Int"

777+ show (B8V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">"

742− show BIType = "Integer"

778+ show (B16V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">"

743− show FlType = "Float"

779+ show (B32V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">"

780+ show (B64V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">"

781+ show (AType ATFloat) = "Float"

782+ show (AType (ATInt ITBig)) = "Integer"

783+ show (AType (ATInt ITNative)) = "Int"

784+ show (AType (ATInt (ITFixed it))) = itBitsName it

785+ show (AType (ATInt (ITVec it c))) = itBitsName it ++ "x" ++ show c

744 show ChType = "Char"

786 show ChType = "Char"

745 show StrType = "String"

787 show StrType = "String"

746 show PtrType = "Ptr"

788 show PtrType = "Ptr"

747− show B8Type = "Bits8"

748− show B16Type = "Bits16"

749− show B32Type = "Bits32"

750− show B64Type = "Bits64"

751 show VoidType = "Void"

789 show VoidType = "Void"

752

790

753showEnv env t = showEnv' env t False

791showEnv env t = showEnv' env t False

src/Core/Typecheck.hs+12−7

@@ -5,6 +5,7 @@ module Core.Typecheck where

6import Control.Monad.State

7import Debug.Trace

8+import qualified Data.Vector.Unboxed as V (length)

9import Core.TT

10import Core.TT

10import Core.Evaluate

11import Core.Evaluate

@@ -98,15 +99,19 @@ check' holes ctxt env top = chk env top where

98 return (TType (UVar v), TType (UVar (v+1)))

99 return (TType (UVar v), TType (UVar (v+1)))

99 chk env (RConstant Forgot) = return (Erased, Erased)

100 chk env (RConstant Forgot) = return (Erased, Erased)

100 chk env (RConstant c) = return (Constant c, constType c)

101 chk env (RConstant c) = return (Constant c, constType c)

101− where constType (I _) = Constant IType

102+ where constType (I _) = Constant (AType (ATInt ITNative))

102− constType (BI _) = Constant BIType

103+ constType (BI _) = Constant (AType (ATInt ITBig))

103− constType (Fl _) = Constant FlType

104+ constType (Fl _) = Constant (AType ATFloat)

104 constType (Ch _) = Constant ChType

105 constType (Ch _) = Constant ChType

105 constType (Str _) = Constant StrType

106 constType (Str _) = Constant StrType

106− constType (B8 _) = Constant B8Type

107+ constType (B8 _) = Constant (AType (ATInt (ITFixed IT8)))

107− constType (B16 _) = Constant B16Type

108+ constType (B16 _) = Constant (AType (ATInt (ITFixed IT16)))

108− constType (B32 _) = Constant B32Type

109+ constType (B32 _) = Constant (AType (ATInt (ITFixed IT32)))

109− constType (B64 _) = Constant B64Type

110+ constType (B64 _) = Constant (AType (ATInt (ITFixed IT64)))

111+ constType (B8V a) = Constant (AType (ATInt (ITVec IT8 (V.length a))))

112+ constType (B16V a) = Constant (AType (ATInt (ITVec IT16 (V.length a))))

113+ constType (B32V a) = Constant (AType (ATInt (ITVec IT32 (V.length a))))

114+ constType (B64V a) = Constant (AType (ATInt (ITVec IT64 (V.length a))))

110 constType Forgot = Erased

115 constType Forgot = Erased

111 constType _ = TType (UVal 0)

116 constType _ = TType (UVal 0)

112 chk env (RForce t) = do (_, ty) <- chk env t

117 chk env (RForce t) = do (_, ty) <- chk env t

src/IRTS/CodegenC.hs+88−77

@@ -229,39 +229,41 @@ bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0);

229

230

231

232−c_irts (FInt ITNative) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

232+c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

233+c_irts (FArith (ATInt (ITFixed ity))) l x

233−c_irts (FInt ty) l x = l ++ "idris_b" ++ show (intTyWidth ty) ++ "const(vm, " ++ x ++ ")"

234+ = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"

234c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

235c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

235c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"

236c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"

236c_irts FUnit l x = x

237c_irts FUnit l x = x

237c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

238c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

238−c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

239+c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

239c_irts FAny l x = l ++ x

240c_irts FAny l x = l ++ x

240

241

241−irts_c (FInt ITNative) x = "GETINT(" ++ x ++ ")"

242+irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"

242−irts_c (FInt ty) x = "(" ++ x ++ "->info.bits" ++ show (intTyWidth ty) ++ ")"

243+irts_c (FArith (ATInt (ITFixed ity))) x

244+ = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"

243irts_c FChar x = "GETINT(" ++ x ++ ")"

245irts_c FChar x = "GETINT(" ++ x ++ ")"

244irts_c FString x = "GETSTR(" ++ x ++ ")"

246irts_c FString x = "GETSTR(" ++ x ++ ")"

245irts_c FUnit x = x

247irts_c FUnit x = x

246irts_c FPtr x = "GETPTR(" ++ x ++ ")"

248irts_c FPtr x = "GETPTR(" ++ x ++ ")"

247−irts_c FDouble x = "GETFLOAT(" ++ x ++ ")"

249+irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

248irts_c FAny x = x

250irts_c FAny x = x

249

251

250−bitOp v op ty args = v ++ "idris_b" ++ show (intTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

252+bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

251

253

252bitCoerce v op input output arg

254bitCoerce v op input output arg

253− = v ++ "idris_b" ++ show (intTyWidth input) ++ op ++ show (intTyWidth output) ++ "(vm, " ++ creg arg ++ ")"

255+ = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"

254

256

255−signedTy :: IntTy -> String

257+signedTy :: NativeTy -> String

256−signedTy t = "int" ++ show (intTyWidth t) ++ "_t"

258+signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"

257

259

258−doOp v (LPlus ITNative) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"

260+doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"

259−doOp v (LMinus ITNative) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

261+doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

260−doOp v (LTimes ITNative) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"

262+doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"

261doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

263doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

262−doOp v (LSDiv ITNative) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

264+doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

263doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"

265doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"

264−doOp v (LSRem ITNative) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"

266+doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"

265doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"

267doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"

266doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"

268doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"

267doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"

269doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"

@@ -269,34 +271,34 @@ doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++

269doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"

271doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"

270doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"

272doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"

271doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"

273doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"

272−doOp v (LEq ITNative) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

274+doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

273−doOp v (LLt ITNative) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"

275+doOp v (LLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"

274−doOp v (LLe ITNative) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

276+doOp v (LLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

275−doOp v (LGt ITNative) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

277+doOp v (LGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

276−doOp v (LGe ITNative) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

278+doOp v (LGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

277−

279+

278−doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"

280+doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"

279−doOp v LFMinus [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

281+doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

280−doOp v LFTimes [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"

282+doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"

281−doOp v LFDiv [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

283+doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

282−doOp v LFEq [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

284+doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

283−doOp v LFLt [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"

285+doOp v (LLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"

284−doOp v LFLe [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

286+doOp v (LLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

285−doOp v LFGt [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

287+doOp v (LGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

286−doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

288+doOp v (LGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

287

289

288doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"

290doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"

289doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"

291doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"

290−doOp v (LPlus ITBig) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

292+doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

291−doOp v (LMinus ITBig) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

293+doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

292−doOp v (LTimes ITBig) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

294+doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

293−doOp v (LSDiv ITBig) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

295+doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

294−doOp v (LSRem ITBig) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

296+doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

295−doOp v (LEq ITBig) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

297+doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

296−doOp v (LLt ITBig) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

298+doOp v (LLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

297−doOp v (LLe ITBig) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

299+doOp v (LLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

298−doOp v (LGt ITBig) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

300+doOp v (LGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

299−doOp v (LGe ITBig) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

301+doOp v (LGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

300

302

301doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

303doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

302doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

304doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

@@ -318,43 +320,52 @@ doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"

318doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"

320doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"

319doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"

321doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"

320

322

321−doOp v (LLt ty) [x, y] = bitOp v "Lt" ty [x, y]

323+doOp v (LLt (ATInt (ITFixed ty))) [x, y] = bitOp v "Lt" ty [x, y]

322−doOp v (LLe ty) [x, y] = bitOp v "Lte" ty [x, y]

324+doOp v (LLe (ATInt (ITFixed ty))) [x, y] = bitOp v "Lte" ty [x, y]

323−doOp v (LEq ty) [x, y] = bitOp v "Eq" ty [x, y]

325+doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]

324−doOp v (LGe ty) [x, y] = bitOp v "Gte" ty [x, y]

326+doOp v (LGe (ATInt (ITFixed ty))) [x, y] = bitOp v "Gte" ty [x, y]

325−doOp v (LGt ty) [x, y] = bitOp v "Gt" ty [x, y]

327+doOp v (LGt (ATInt (ITFixed ty))) [x, y] = bitOp v "Gt" ty [x, y]

326−

328+

327−doOp v (LSHL ty) [x, y] = bitOp v "Shl" ty [x, y]

329+doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]

328−doOp v (LLSHR ty) [x, y] = bitOp v "LShr" ty [x, y]

330+doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]

329−doOp v (LASHR ty) [x, y] = bitOp v "AShr" ty [x, y]

331+doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]

330−doOp v (LAnd ty) [x, y] = bitOp v "And" ty [x, y]

332+doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]

331−doOp v (LOr ty) [x, y] = bitOp v "Or" ty [x, y]

333+doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]

332−doOp v (LXOr ty) [x, y] = bitOp v "Xor" ty [x, y]

334+doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]

333−doOp v (LCompl ty) [x] = bitOp v "Compl" ty [x]

335+doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]

334−

336+

335−doOp v (LPlus ty) [x, y] = bitOp v "Plus" ty [x, y]

337+doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]

336−doOp v (LMinus ty) [x, y] = bitOp v "Minus" ty [x, y]

338+doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]

337−doOp v (LTimes ty) [x, y] = bitOp v "Times" ty [x, y]

339+doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]

338−doOp v (LUDiv ty) [x, y] = bitOp v "UDiv" ty [x, y]

340+doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]

339−doOp v (LSDiv ty) [x, y] = bitOp v "SDiv" ty [x, y]

341+doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]

340−doOp v (LURem ty) [x, y] = bitOp v "URem" ty [x, y]

342+doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]

341−doOp v (LSRem ty) [x, y] = bitOp v "SRem" ty [x, y]

343+doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]

342−

344+

345+doOp v (LSExt (ITFixed from) ITBig) [x]

343−doOp v (LSExt from ITBig) [x] = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

346+ = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"

347+doOp v (LSExt ITNative (ITFixed to)) [x]

344−doOp v (LSExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"

348+ = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"

349+doOp v (LSExt (ITFixed from) ITNative) [x]

345−doOp v (LSExt from ITNative) [x] = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ "))"

350+ = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"

346−doOp v (LSExt from to) [x]

351+doOp v (LSExt (ITFixed from) (ITFixed to)) [x]

347− | intTyWidth from < intTyWidth to = bitCoerce v "S" from to x

352+ | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x

353+doOp v (LZExt ITNative (ITFixed to)) [x]

348−doOp v (LZExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"

354+ = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"

355+doOp v (LZExt (ITFixed from) ITNative) [x]

349−doOp v (LZExt from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

356+ = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"

357+doOp v (LZExt (ITFixed from) ITBig) [x]

350−doOp v (LZExt from ITBig) [x] = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

358+ = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"

351−doOp v (LZExt from to) [x]

359+doOp v (LZExt (ITFixed from) (ITFixed to)) [x]

352− | intTyWidth from < intTyWidth to = bitCoerce v "Z" from to x

360+ | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x

361+doOp v (LTrunc ITNative (ITFixed to)) [x]

353−doOp v (LTrunc ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"

362+ = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"

363+doOp v (LTrunc (ITFixed from) ITNative) [x]

354−doOp v (LTrunc from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

364+ = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"

365+doOp v (LTrunc ITBig (ITFixed to)) [x]

355−doOp v (LTrunc ITBig to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"

366+ = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"

356−doOp v (LTrunc from to) [x]

367+doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]

357− | intTyWidth from > intTyWidth to = bitCoerce v "T" from to x

368+ | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x

358

369

359doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)

370doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)

360doOp v LFLog [x] = v ++ flUnOp "log" (creg x)

371doOp v LFLog [x] = v ++ flUnOp "log" (creg x)

src/IRTS/CodegenJava.hs+79−79

@@ -472,17 +472,17 @@ longType :: ClassType

472longType = ClassType [(Ident "Long", [])]

473

474nextIntTy :: IntTy -> IntTy

475−nextIntTy IT8 = IT16

475+nextIntTy (ITFixed IT8) = (ITFixed IT16)

476−nextIntTy IT16 = IT32

476+nextIntTy (ITFixed IT16) = (ITFixed IT32)

477−nextIntTy IT32 = IT64

477+nextIntTy (ITFixed IT32) = (ITFixed IT64)

478−nextIntTy IT64 = IT64

478+nextIntTy (ITFixed IT64) = (ITFixed IT64)

479−nextIntTy ITNative = IT64

479+nextIntTy ITNative = (ITFixed IT64)

480

481intTyToIdent :: IntTy -> Ident

482−intTyToIdent IT8 = Ident "Byte"

482+intTyToIdent (ITFixed IT8) = Ident "Byte"

483−intTyToIdent IT16 = Ident "Short"

483+intTyToIdent (ITFixed IT16) = Ident "Short"

484−intTyToIdent IT32 = Ident "Integer"

484+intTyToIdent (ITFixed IT32) = Ident "Integer"

485−intTyToIdent IT64 = Ident "Long"

485+intTyToIdent (ITFixed IT64) = Ident "Long"

486intTyToIdent ITNative = Ident "Integer"

487intTyToIdent ITBig = Ident "BigInteger"

488

@@ -490,17 +490,17 @@ intTyToClass :: IntTy -> ClassType

490intTyToClass ty = ClassType [(intTyToIdent ty, [])]

491

492intTyToMethod :: IntTy -> String

493−intTyToMethod IT8 = "byteValue"

493+intTyToMethod (ITFixed IT8) = "byteValue"

494−intTyToMethod IT16 = "shortValue"

494+intTyToMethod (ITFixed IT16) = "shortValue"

495−intTyToMethod IT32 = "intValue"

495+intTyToMethod (ITFixed IT32) = "intValue"

496−intTyToMethod IT64 = "longValue"

496+intTyToMethod (ITFixed IT64) = "longValue"

497intTyToMethod ITNative = "intValue"

498

499intTyToPrimTy :: IntTy -> PrimType

500−intTyToPrimTy IT8 = ByteT

500+intTyToPrimTy (ITFixed IT8) = ByteT

501−intTyToPrimTy IT16 = ShortT

501+intTyToPrimTy (ITFixed IT16) = ShortT

502−intTyToPrimTy IT32 = IntT

502+intTyToPrimTy (ITFixed IT32) = IntT

503−intTyToPrimTy IT64 = LongT

503+intTyToPrimTy (ITFixed IT64) = LongT

504intTyToPrimTy ITNative = IntT

505

506bigIntegerType :: ClassType

@@ -995,24 +995,24 @@ mkStringAtIndex var indexExp =

995 <$> mkVarAccess (Just stringType) var

996

997mkForeignType :: FType -> Maybe ClassType

998−mkForeignType (FInt ty) = return (intTyToClass ty)

998+mkForeignType (FArith (ATInt ity)) = return (intTyToClass ity)

999+mkForeignType (FArith ATFloat) = return doubleType

999mkForeignType FChar = return integerType

1000mkForeignType FChar = return integerType

1000mkForeignType FString = return stringType

1001mkForeignType FString = return stringType

1001mkForeignType FPtr = return objectType

1002mkForeignType FPtr = return objectType

1002−mkForeignType FDouble = return doubleType

1003mkForeignType FAny = return objectType

1004mkForeignType FUnit = Nothing

1005

1006mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp

1007−mkForeignVarAccess (FInt ty) var =

1007+mkForeignVarAccess (FArith (ATInt ty)) var =

1008 (\ var -> MethodInv $ PrimaryMethodCall var

1009 []

1010 (Ident (intTyToMethod ty))

1011 []

1012 )

1013 <$> mkVarAccess (Just $ intTyToClass ty) var

1014−mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FInt IT32) var

1014+mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FArith (ATInt (ITFixed IT32))) var

1015−mkForeignVarAccess FDouble var =

1015+mkForeignVarAccess (FArith ATFloat) var =

1016 (\ var -> MethodInv $ PrimaryMethodCall (var)

1017 []

1018 (Ident "doubleValue")

@@ -1022,13 +1022,13 @@ mkForeignVarAccess FDouble var =

1022mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var

1023

1024mkFromForeignType :: FType -> Exp -> Exp

1025−mkFromForeignType (FInt ty) from =

1025+mkFromForeignType (FArith (ATInt ty)) from =

1026 MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty])

1027 []

1028 (Ident "valueOf")

1029 [from]

1030−mkFromForeignType FChar from = mkFromForeignType (FInt IT32) from

1030+mkFromForeignType FChar from = mkFromForeignType (FArith (ATInt (ITFixed IT32))) from

1031−mkFromForeignType FDouble from =

1031+mkFromForeignType (FArith ATFloat) from =

1032 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])

1033 []

1034 (Ident "valueOf")

@@ -1269,78 +1269,78 @@ mkExp (SConst (BI x)) =

1269mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)

1270mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)

1271mkExp (SConst (Str x)) = return $ Lit $ String x

1272−mkExp (SConst IType) = return $ mkClass integerType

1272+mkExp (SConst (AType (ATInt ITNative))) = return $ mkClass integerType

1273−mkExp (SConst BIType) = return $ mkClass bigIntegerType

1273+mkExp (SConst (AType (ATInt ITBig))) = return $ mkClass bigIntegerType

1274−mkExp (SConst FlType) = return $ mkClass doubleType

1274+mkExp (SConst (AType ATFloat)) = return $ mkClass doubleType

1275mkExp (SConst ChType) = return $ mkClass charType

1276mkExp (SConst StrType) = return $ mkClass stringType

1277mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))

1278mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))

1279mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))

1280mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x))

1281−mkExp (SConst (B8Type))= return $ mkClass byteType

1281+mkExp (SConst (AType (ATInt (ITFixed IT8)))) = return $ mkClass byteType

1282−mkExp (SConst (B16Type)) = return $ mkClass shortType

1282+mkExp (SConst (AType (ATInt (ITFixed IT16)))) = return $ mkClass shortType

1283−mkExp (SConst (B32Type)) = return $ mkClass integerType

1283+mkExp (SConst (AType (ATInt (ITFixed IT32)))) = return $ mkClass integerType

1284−mkExp (SConst (B64Type)) = return $ mkClass longType

1284+mkExp (SConst (AType (ATInt (ITFixed IT64)))) = return $ mkClass longType

1285mkExp (SConst (PtrType)) = return $ mkClass objectType

1286mkExp (SConst (VoidType)) = return $ mkClass voidType

1287mkExp (SConst (Forgot)) = return $ mkClass objectType

1288mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args

1289−mkExp (SOp (LPlus ITNative) args) = mkExp (SOp (LPlus IT32) args)

1289+mkExp (SOp (LPlus (ATInt ITNative)) args) = mkExp (SOp (LPlus (ATInt (ITFixed IT32))) args)

1290−mkExp (SOp (LMinus ITNative) args) = mkExp (SOp (LMinus IT32) args)

1290+mkExp (SOp (LMinus (ATInt ITNative)) args) = mkExp (SOp (LMinus (ATInt (ITFixed IT32))) args)

1291−mkExp (SOp (LTimes ITNative) args) = mkExp (SOp (LTimes IT32) args)

1291+mkExp (SOp (LTimes (ATInt ITNative)) args) = mkExp (SOp (LTimes (ATInt (ITFixed IT32))) args)

1292−mkExp (SOp (LSDiv ITNative) args) = mkExp (SOp (LSDiv IT32) args)

1292+mkExp (SOp (LSDiv (ATInt ITNative)) args) = mkExp (SOp (LSDiv (ATInt (ITFixed IT32))) args)

1293−mkExp (SOp (LSRem ITNative) args) = mkExp (SOp (LSRem IT32) args)

1293+mkExp (SOp (LSRem (ATInt ITNative)) args) = mkExp (SOp (LSRem (ATInt (ITFixed IT32))) args)

1294−mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd IT32) args)

1294+mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd (ITFixed IT32)) args)

1295−mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr IT32) args)

1295+mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr (ITFixed IT32)) args)

1296−mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr IT32) args)

1296+mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr (ITFixed IT32)) args)

1297−mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl IT32) args)

1297+mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl (ITFixed IT32)) args)

1298−mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL IT32) args)

1298+mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL (ITFixed IT32)) args)

1299−mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR IT32) args)

1299+mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR (ITFixed IT32)) args)

1300−mkExp (SOp (LEq ITNative) args) = mkExp (SOp (LEq IT32) args)

1300+mkExp (SOp (LEq (ATInt ITNative)) args) = mkExp (SOp (LEq (ATInt (ITFixed IT32))) args)

1301−mkExp (SOp (LLt ITNative) args) = mkExp (SOp (LLt IT32) args)

1301+mkExp (SOp (LLt (ATInt ITNative)) args) = mkExp (SOp (LLt (ATInt (ITFixed IT32))) args)

1302−mkExp (SOp (LLe ITNative) args) = mkExp (SOp (LLe IT32) args)

1302+mkExp (SOp (LLe (ATInt ITNative)) args) = mkExp (SOp (LLe (ATInt (ITFixed IT32))) args)

1303−mkExp (SOp (LGt ITNative) args) = mkExp (SOp (LGt IT32) args)

1303+mkExp (SOp (LGt (ATInt ITNative)) args) = mkExp (SOp (LGt (ATInt (ITFixed IT32))) args)

1304−mkExp (SOp (LGe ITNative) args) = mkExp (SOp (LGe IT32) args)

1304+mkExp (SOp (LGe (ATInt ITNative)) args) = mkExp (SOp (LGe (ATInt (ITFixed IT32))) args)

1305−mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args

1305+mkExp (SOp (LPlus ATFloat) args) = mkBinOpExp doubleType Add args

1306−mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args

1306+mkExp (SOp (LMinus ATFloat) args) = mkBinOpExp doubleType Sub args

1307−mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args

1307+mkExp (SOp (LTimes ATFloat) args) = mkBinOpExp doubleType Mult args

1308−mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args

1308+mkExp (SOp (LSDiv ATFloat) args) = mkBinOpExp doubleType Div args

1309−mkExp (SOp LFEq args) =

1309+mkExp (SOp (LEq ATFloat) args) =

1310 mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args

1311−mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args

1311+mkExp (SOp (LLt ATFloat) args) = mkLogicalBinOpExp integerType LThan args

1312−mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args

1312+mkExp (SOp (LLe ATFloat) args) = mkLogicalBinOpExp integerType LThanE args

1313−mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args

1313+mkExp (SOp (LGt ATFloat) args) = mkLogicalBinOpExp integerType GThan args

1314−mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args

1314+mkExp (SOp (LGe ATFloat) args) = mkLogicalBinOpExp integerType GThanE args

1315−mkExp (SOp (LPlus ITBig) args) = mkMethodOpChain1 id bigIntegerType "add" args

1315+mkExp (SOp (LPlus (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "add" args

1316−mkExp (SOp (LMinus ITBig) args) = mkMethodOpChain1 id bigIntegerType "subtract" args

1316+mkExp (SOp (LMinus (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "subtract" args

1317−mkExp (SOp (LTimes ITBig) args) = mkMethodOpChain1 id bigIntegerType "multiply" args

1317+mkExp (SOp (LTimes (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "multiply" args

1318−mkExp (SOp (LSDiv ITBig) args) = mkMethodOpChain1 id bigIntegerType "divide" args

1318+mkExp (SOp (LSDiv (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "divide" args

1319−mkExp (SOp (LSRem ITBig) args) = mkMethodOpChain1 id bigIntegerType "mod" args

1319+mkExp (SOp (LSRem (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "mod" args

1320−mkExp (SOp (LEq ITBig) args) =

1320+mkExp (SOp (LEq (ATInt ITBig)) args) =

1321 mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args

1322−mkExp (SOp (LLt ITBig) args) =

1322+mkExp (SOp (LLt (ATInt ITBig)) args) =

1323 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1324 . mkPartialOrder SLt

1325 )

1326 bigIntegerType

1327 "compareTo"

1328 args

1329−mkExp (SOp (LLe ITBig) args) =

1329+mkExp (SOp (LLe (ATInt ITBig)) args) =

1330 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1331 . mkPartialOrder SLe

1332 )

1333 bigIntegerType

1334 "compareTo"

1335 args

1336−mkExp (SOp (LGt ITBig) args) =

1336+mkExp (SOp (LGt (ATInt ITBig)) args) =

1337 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1338 . mkPartialOrder SGt

1339 )

1340 bigIntegerType

1341 "compareTo"

1342 args

1343−mkExp (SOp (LGe ITBig) args) =

1343+mkExp (SOp (LGe (ATInt ITBig)) args) =

1344 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1345 . mkPartialOrder SGe

1346 )

@@ -1397,16 +1397,16 @@ mkExp (SOp LPrintNum [arg]) =

1397mkExp (SOp LPrintStr [arg]) =

1398 mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)

1399mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])

1400−mkExp (SOp (LLt ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args

1400+mkExp (SOp (LLt (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args

1401−mkExp (SOp (LLe ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args

1401+mkExp (SOp (LLe (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args

1402−mkExp (SOp (LEq ty) args) =

1402+mkExp (SOp (LEq (ATInt ty)) args) =

1403 mkMethodOpChain1 (mkBoolToNumber (intTyToClass ty)) (intTyToClass ty) "equals" args

1404−mkExp (SOp (LGt ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args

1404+mkExp (SOp (LGt (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args

1405−mkExp (SOp (LGe ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args

1405+mkExp (SOp (LGe (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args

1406−mkExp (SOp (LPlus ty) args) = mkBinOpExp (intTyToClass ty) Add args

1406+mkExp (SOp (LPlus (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Add args

1407−mkExp (SOp (LMinus ty) args) = mkBinOpExp (intTyToClass ty) Sub args

1407+mkExp (SOp (LMinus (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Sub args

1408−mkExp (SOp (LTimes ty) args) = mkBinOpExp (intTyToClass ty) Mult args

1408+mkExp (SOp (LTimes (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Mult args

1409−mkExp (SOp (LUDiv IT64) (arg:args)) = do

1409+mkExp (SOp (LUDiv (ITFixed IT64)) (arg:args)) = do

1410 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)

1411 return $ foldl (\ exp arg ->

1412 MethodInv $ PrimaryMethodCall

@@ -1436,8 +1436,8 @@ mkExp (SOp (LUDiv ty) args) =

1436 (intTyToClass ty)

1437 Div

1438 args

1439−mkExp (SOp (LSDiv ty) args) = mkBinOpExp (intTyToClass ty) Div args

1439+mkExp (SOp (LSDiv (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Div args

1440−mkExp (SOp (LURem IT64) (arg:args)) = do

1440+mkExp (SOp (LURem (ITFixed IT64)) (arg:args)) = do

1441 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)

1442 return $ foldl (\ exp arg ->

1443 MethodInv $ PrimaryMethodCall

@@ -1467,7 +1467,7 @@ mkExp (SOp (LURem ty) args) =

1467 (intTyToClass ty)

1468 Rem

1469 args

1470−mkExp (SOp (LSRem ty) args) = mkBinOpExp (intTyToClass ty) Rem args

1470+mkExp (SOp (LSRem (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Rem args

1471mkExp (SOp (LSHL ty) args) = mkBinOpExp (intTyToClass ty) LShift args

1472mkExp (SOp (LLSHR ty) args) = mkBinOpExp (intTyToClass ty) RRShift args

1473mkExp (SOp (LASHR ty) args) = mkBinOpExp (intTyToClass ty) RShift args

src/IRTS/CodegenJavaScript.hs+29−29

@@ -143,11 +143,11 @@ translateConstant (BI i) = "__IDRRT__.bigInt('" ++ show i ++ "')"

143translateConstant (Fl f) = show f

144translateConstant (Ch c) = show c

145translateConstant (Str s) = show s

146−translateConstant IType = "__IDRRT__.Int"

146+translateConstant (AType (ATInt ITNative)) = "__IDRRT__.Int"

147translateConstant ChType = "__IDRRT__.Char"

148translateConstant StrType = "__IDRRT__.String"

149−translateConstant BIType = "__IDRRT__.Integer"

149+translateConstant (AType (ATInt ITBig)) = "__IDRRT__.Integer"

150−translateConstant FlType = "__IDRRT__.Float"

150+translateConstant (AType ATFloat) = "__IDRRT__.Float"

151translateConstant PtrType = "__IDRRT__.Ptr"

152translateConstant Forgot = "__IDRRT__.Forgot"

153translateConstant c =

@@ -245,44 +245,44 @@ translateExpression (SOp op vars)

245 | (LCompl _) <- op

246 , (arg:_) <- vars = '~' : translateVariableName arg

247

248− | (LPlus ITBig) <- op

248+ | (LPlus (ATInt ITBig)) <- op

249 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"

250− | (LMinus ITBig) <- op

250+ | (LMinus (ATInt ITBig)) <- op

251 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"

252− | (LTimes ITBig) <- op

252+ | (LTimes (ATInt ITBig)) <- op

253 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"

254− | (LSDiv ITBig) <- op

254+ | (LSDiv (ATInt ITBig)) <- op

255 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"

256− | (LSRem ITBig) <- op

256+ | (LSRem (ATInt ITBig)) <- op

257 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"

258− | (LEq ITBig) <- op

258+ | (LEq (ATInt ITBig)) <- op

259 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"

260− | (LLt ITBig) <- op

260+ | (LLt (ATInt ITBig)) <- op

261 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"

262− | (LLe ITBig) <- op

262+ | (LLe (ATInt ITBig)) <- op

263 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"

264− | (LGt ITBig) <- op

264+ | (LGt (ATInt ITBig)) <- op

265 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"

266− | (LGe ITBig) <- op

266+ | (LGe (ATInt ITBig)) <- op

267 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"

268

269− | LFPlus <- op

269+ | (LPlus ATFloat) <- op

270 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

271− | LFMinus <- op

271+ | (LMinus ATFloat) <- op

272 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs

273− | LFTimes <- op

273+ | (LTimes ATFloat) <- op

274 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs

275− | LFDiv <- op

275+ | (LSDiv ATFloat) <- op

276 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs

277− | LFEq <- op

277+ | (LEq ATFloat) <- op

278 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs

279− | LFLt <- op

279+ | (LLt ATFloat) <- op

280 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs

281− | LFLe <- op

281+ | (LLe ATFloat) <- op

282 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs

283− | LFGt <- op

283+ | (LGt ATFloat) <- op

284 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs

285− | LFGe <- op

285+ | (LGe ATFloat) <- op

286 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs

287

288 | LStrConcat <- op

@@ -470,13 +470,13 @@ translateCase _ (SDefaultCase e) =

470 createIfBlock "true" (translateExpression e)

471

472translateCase var (SConstCase ty e)

473− | ChType <- ty = matchHelper "Char"

473+ | ChType <- ty = matchHelper "Char"

474− | StrType <- ty = matchHelper "String"

474+ | StrType <- ty = matchHelper "String"

475− | IType <- ty = matchHelper "Int"

476− | BIType <- ty = matchHelper "Integer"

477− | FlType <- ty = matchHelper "Float"

478− | PtrType <- ty = matchHelper "Ptr"

475+ | PtrType <- ty = matchHelper "Ptr"

479− | Forgot <- ty = matchHelper "Forgot"

476+ | Forgot <- ty = matchHelper "Forgot"

477+ | (AType ATFloat) <- ty = matchHelper "Float"

478+ | (AType (ATInt ITBig)) <- ty = matchHelper "Integer"

479+ | (AType (ATInt ITNative)) <- ty = matchHelper "Int"

480 where

481 matchHelper tyName = translateTypeMatch var tyName e

482

src/IRTS/CodegenLLVM.hs+86−81

@@ -5,6 +5,7 @@ import IRTS.CodegenCommon

5import IRTS.Lang

6import IRTS.Simplified

7import qualified Core.TT as TT

8+import Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth)

9import Util.System

10import Util.System

10import Paths_idris

11import Paths_idris

@@ -80,12 +81,8 @@ codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do

80failInIO :: ErrorT String IO a -> IO a

81failInIO :: ErrorT String IO a -> IO a

81failInIO = either fail return <=< runErrorT

82failInIO = either fail return <=< runErrorT

83−itWidth :: IntTy -> Word32

84−itWidth ITNative = 32

85−itWidth x = fromIntegral $ intTyWidth x

86−

87outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()

84outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()

88−outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m

85+outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m

89outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m

86outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m

90outputModule tm file Executable m = withTmpFile $ \obj -> do

87outputModule tm file Executable m = withTmpFile $ \obj -> do

91 outputModule tm obj Object m

88 outputModule tm obj Object m

@@ -586,7 +583,7 @@ cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)

586cgChainCase caseValPtr defExp alts = do

583cgChainCase caseValPtr defExp alts = do

587 let (caseTy, comparator) =

584 let (caseTy, comparator) =

588 case head alts of

585 case head alts of

589− SConstCase (TT.BI _) _ -> (FInt ITBig, "__gmpz_cmp")

586+ SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp")

590 SConstCase (TT.Str _) _ -> (FString, "strcmp")

587 SConstCase (TT.Str _) _ -> (FString, "strcmp")

591 caseVal <- unbox caseTy caseValPtr

588 caseVal <- unbox caseTy caseValPtr

592 defBlockName <- getName "default"

589 defBlockName <- getName "default"

@@ -719,12 +716,12 @@ cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fro

719cgConst' x = ierror $ "Unsupported constant: " ++ show x

716cgConst' x = ierror $ "Unsupported constant: " ++ show x

720

717

721cgConst :: TT.Const -> Codegen Operand

718cgConst :: TT.Const -> Codegen Operand

722−cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)

719+cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c)

723−cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)

720+cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c)

724−cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)

721+cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c)

725−cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)

722+cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c)

726−cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)

723+cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c)

727−cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)

724+cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c)

728cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)

725cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)

729cgConst c@(TT.Str s) = do

726cgConst c@(TT.Str s) = do

730 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)

727 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)

@@ -736,7 +733,7 @@ cgConst c@(TT.BI i) = do

736 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]

733 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]

737 , ConstantOperand $ C.Int 32 10

734 , ConstantOperand $ C.Int 32 10

738 ]

735 ]

739− box (FInt ITBig) mpz

736+ box (FArith (ATInt ITBig)) mpz

740cgConst x = return $ ConstantOperand nullValue

737cgConst x = return $ ConstantOperand nullValue

741

738

742numDigits :: Integer -> Integer -> Integer

739numDigits :: Integer -> Integer -> Integer

@@ -782,72 +779,80 @@ ffunDecl name rty argtys =

782 }

779 }

783

780

784ftyToTy :: FType -> Type

781ftyToTy :: FType -> Type

785−ftyToTy (FInt ITNative) = IntegerType 32

782+ftyToTy (FArith (ATInt ITNative)) = IntegerType 32

786−ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)

783+ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0)

787−ftyToTy (FInt ty) = IntegerType (itWidth ty)

784+ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty)

788ftyToTy FChar = IntegerType 32

785ftyToTy FChar = IntegerType 32

789ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)

786ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)

790ftyToTy FUnit = VoidType

787ftyToTy FUnit = VoidType

791ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)

788ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)

792−ftyToTy FDouble = FloatingPointType 64 IEEE

789+ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE

793ftyToTy FAny = valueType

790ftyToTy FAny = valueType

794

791

792+-- Only use when known not to be ITBig

793+itWidth :: IntTy -> Word32

794+itWidth ITNative = 32

795+itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x

796+

795cgOp :: PrimFn -> [Operand] -> Codegen Operand

797cgOp :: PrimFn -> [Operand] -> Codegen Operand

796cgOp (LTrunc ITBig ity) [x] = do

798cgOp (LTrunc ITBig ity) [x] = do

797− nx <- unbox (FInt ITBig) x

799+ nx <- unbox (FArith (ATInt ITBig)) x

798 val <- inst $ simpleCall "mpz_get_ull" [nx]

800 val <- inst $ simpleCall "mpz_get_ull" [nx]

799 v <- case ity of

801 v <- case ity of

800− IT64 -> return val

802+ (ITFixed IT64) -> return val

801− _ -> inst $ Trunc val (IntegerType $ itWidth ity) []

803+ _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) []

802− box (FInt ity) v

804+ box (FArith (ATInt ity)) v

803cgOp (LZExt from ITBig) [x] = do

805cgOp (LZExt from ITBig) [x] = do

804− nx <- unbox (FInt from) x

806+ nx <- unbox (FArith (ATInt from)) x

805 nx' <- case from of

807 nx' <- case from of

806− IT64 -> return nx

808+ (ITFixed IT64) -> return nx

807 _ -> inst $ ZExt nx (IntegerType 64) []

809 _ -> inst $ ZExt nx (IntegerType 64) []

808 mpz <- alloc mpzTy

810 mpz <- alloc mpzTy

809 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']

811 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']

810− box (FInt ITBig) mpz

812+ box (FArith (ATInt ITBig)) mpz

811cgOp (LSExt from ITBig) [x] = do

813cgOp (LSExt from ITBig) [x] = do

812− nx <- unbox (FInt from) x

814+ nx <- unbox (FArith (ATInt from)) x

813 nx' <- case from of

815 nx' <- case from of

814− IT64 -> return nx

816+ (ITFixed IT64) -> return nx

815 _ -> inst $ SExt nx (IntegerType 64) []

817 _ -> inst $ SExt nx (IntegerType 64) []

816 mpz <- alloc mpzTy

818 mpz <- alloc mpzTy

817 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']

819 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']

818− box (FInt ITBig) mpz

820+ box (FArith (ATInt ITBig)) mpz

819−

821+

820−cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y

822+cgOp (LLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y

821−cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y

823+cgOp (LLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y

822−cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y

824+cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y

823−cgOp (LGe ITBig) [x,y] = mpzCmp IPred.SGE x y

825+cgOp (LGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y

824−cgOp (LGt ITBig) [x,y] = mpzCmp IPred.SGT x y

826+cgOp (LGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y

825−cgOp (LPlus ITBig) [x,y] = mpzBin "add" x y

827+cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y

826−cgOp (LMinus ITBig) [x,y] = mpzBin "sub" x y

828+cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y

827−cgOp (LTimes ITBig) [x,y] = mpzBin "mul" x y

829+cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y

828−cgOp (LSDiv ITBig) [x,y] = mpzBin "fdiv_q" x y

830+cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y

829−cgOp (LSRem ITBig) [x,y] = mpzBin "fdiv_r" x y

831+cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y

830cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y

832cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y

831cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y

833cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y

832cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y

834cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y

833cgOp (LCompl ITBig) [x] = mpzUn "com" x

835cgOp (LCompl ITBig) [x] = mpzUn "com" x

834

836

837+cgOp (LTrunc (ITFixed from) (ITFixed to)) [x]

835−cgOp (LTrunc from to) [x] | itWidth from > itWidth to = iCoerce Trunc from to x

838+ | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x

839+cgOp (LZExt (ITFixed from) (ITFixed to)) [x]

836−cgOp (LZExt from to) [x] | itWidth from < itWidth to = iCoerce ZExt from to x

840+ | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x

841+cgOp (LSExt (ITFixed from) (ITFixed to)) [x]

837−cgOp (LSExt from to) [x] | itWidth from < itWidth to = iCoerce SExt from to x

842+ | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x

838−

843+

839−cgOp (LLt ity) [x,y] = iCmp ity IPred.SLT x y

844+cgOp (LLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y

840−cgOp (LLe ity) [x,y] = iCmp ity IPred.SLE x y

845+cgOp (LLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y

841−cgOp (LEq ity) [x,y] = iCmp ity IPred.EQ x y

846+cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y

842−cgOp (LGe ity) [x,y] = iCmp ity IPred.SGE x y

847+cgOp (LGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y

843−cgOp (LGt ity) [x,y] = iCmp ity IPred.SGT x y

848+cgOp (LGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y

844−cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)

849+cgOp (LPlus (ATInt ity)) [x,y] = ibin ity x y (Add False False)

845−cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)

850+cgOp (LMinus (ATInt ity)) [x,y] = ibin ity x y (Sub False False)

846−cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)

851+cgOp (LTimes (ATInt ity)) [x,y] = ibin ity x y (Mul False False)

852+cgOp (LSDiv (ATInt ity)) [x,y] = ibin ity x y (SDiv False)

853+cgOp (LSRem (ATInt ity)) [x,y] = ibin ity x y SRem

847cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)

854cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)

848cgOp (LURem ity) [x,y] = ibin ity x y URem

855cgOp (LURem ity) [x,y] = ibin ity x y URem

849−cgOp (LSDiv ity) [x,y] = ibin ity x y (SDiv False)

850−cgOp (LSRem ity) [x,y] = ibin ity x y SRem

851cgOp (LAnd ity) [x,y] = ibin ity x y And

856cgOp (LAnd ity) [x,y] = ibin ity x y And

852cgOp (LOr ity) [x,y] = ibin ity x y Or

857cgOp (LOr ity) [x,y] = ibin ity x y Or

853cgOp (LXOr ity) [x,y] = ibin ity x y Xor

858cgOp (LXOr ity) [x,y] = ibin ity x y Xor

@@ -864,7 +869,7 @@ cgOp LStrEq [x,y] = do

864 cmp <- inst $ simpleCall "strcmp" [x', y']

869 cmp <- inst $ simpleCall "strcmp" [x', y']

865 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []

870 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []

866 val <- inst $ ZExt flag (IntegerType 32) []

871 val <- inst $ ZExt flag (IntegerType 32) []

867− box (FInt IT32) val

872+ box (FArith (ATInt (ITFixed IT32))) val

868

873

869cgOp LStrLt [x,y] = do

874cgOp LStrLt [x,y] = do

870 nx <- unbox FString x

875 nx <- unbox FString x

@@ -872,10 +877,10 @@ cgOp LStrLt [x,y] = do

872 cmp <- inst $ simpleCall "strcmp" [nx, ny]

877 cmp <- inst $ simpleCall "strcmp" [nx, ny]

873 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []

878 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []

874 val <- inst $ ZExt flag (IntegerType 32) []

879 val <- inst $ ZExt flag (IntegerType 32) []

875− box (FInt IT32) val

880+ box (FArith (ATInt (ITFixed IT32))) val

876

881

877cgOp (LIntStr ITBig) [x] = do

882cgOp (LIntStr ITBig) [x] = do

878− x' <- unbox (FInt ITBig) x

883+ x' <- unbox (FArith (ATInt ITBig)) x

879 ustr <- inst $ simpleCall "__gmpz_get_str"

884 ustr <- inst $ simpleCall "__gmpz_get_str"

880 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))

885 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))

881 , ConstantOperand (C.Int 32 10)

886 , ConstantOperand (C.Int 32 10)

@@ -883,7 +888,7 @@ cgOp (LIntStr ITBig) [x] = do

883 ]

888 ]

884 box FString ustr

889 box FString ustr

885cgOp (LIntStr ity) [x] = do

890cgOp (LIntStr ity) [x] = do

886− x' <- unbox (FInt ity) x

891+ x' <- unbox (FArith (ATInt ity)) x

887 x'' <- if itWidth ity < 64

892 x'' <- if itWidth ity < 64

888 then inst $ SExt x' (IntegerType 64) []

893 then inst $ SExt x' (IntegerType 64) []

889 else return x'

894 else return x'

@@ -892,7 +897,7 @@ cgOp (LStrInt ITBig) [s] = do

892 ns <- unbox FString s

897 ns <- unbox FString s

893 mpz <- alloc mpzTy

898 mpz <- alloc mpzTy

894 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]

899 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]

895− box (FInt ITBig) mpz

900+ box (FArith (ATInt ITBig)) mpz

896cgOp (LStrInt ity) [s] = do

901cgOp (LStrInt ity) [s] = do

897 ns <- unbox FString s

902 ns <- unbox FString s

898 nx <- inst $ simpleCall "strtoll"

903 nx <- inst $ simpleCall "strtoll"

@@ -901,9 +906,9 @@ cgOp (LStrInt ity) [s] = do

901 , ConstantOperand $ C.Int 32 10

906 , ConstantOperand $ C.Int 32 10

902 ]

907 ]

903 nx' <- case ity of

908 nx' <- case ity of

904− IT64 -> return nx

909+ (ITFixed IT64) -> return nx

905 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []

910 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []

906− box (FInt ity) nx'

911+ box (FArith (ATInt ity)) nx'

907

912

908cgOp LStrConcat [x,y] = cgStrCat x y

913cgOp LStrConcat [x,y] = cgStrCat x y

909

914

@@ -922,7 +927,7 @@ cgOp LStrHead [c] = do

922

927

923cgOp LStrIndex [s, i] = do

928cgOp LStrIndex [s, i] = do

924 ns <- unbox FString s

929 ns <- unbox FString s

925− ni <- unbox (FInt IT32) i

930+ ni <- unbox (FArith (ATInt (ITFixed IT32))) i

926 p <- inst $ GetElementPtr True ns [ni] []

931 p <- inst $ GetElementPtr True ns [ni] []

927 c <- inst $ Load False p Nothing 0 []

932 c <- inst $ Load False p Nothing 0 []

928 c' <- inst $ ZExt c (IntegerType 32) []

933 c' <- inst $ ZExt c (IntegerType 32) []

@@ -941,7 +946,7 @@ cgOp LStrLen [s] = do

941 32 -> return len

946 32 -> return len

942 x | x > 32 -> inst $ Trunc len (IntegerType 32) []

947 x | x > 32 -> inst $ Trunc len (IntegerType 32) []

943 | x < 32 -> inst $ ZExt len (IntegerType 32) []

948 | x < 32 -> inst $ ZExt len (IntegerType 32) []

944− box (FInt IT32) len'

949+ box (FArith (ATInt (ITFixed IT32))) len'

945

950

946cgOp LReadStr [p] = do

951cgOp LReadStr [p] = do

947 np <- unbox FPtr p

952 np <- unbox FPtr p

@@ -964,11 +969,11 @@ cgOp LStdErr [] = do

964cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("

969cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("

965 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"

970 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"

966

971

967−iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> IntTy -> IntTy -> Operand -> Codegen Operand

972+iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand

968iCoerce operator from to x = do

973iCoerce operator from to x = do

969− x' <- unbox (FInt from) x

974+ x' <- unbox (FArith (ATInt (ITFixed from))) x

970− x'' <- inst $ operator x' (IntegerType $ itWidth to) []

975+ x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed from)))) []

971− box (FInt to) x''

976+ box (FArith (ATInt (ITFixed to))) x''

972

977

973cgStrCat :: Operand -> Operand -> Codegen Operand

978cgStrCat :: Operand -> Operand -> Codegen Operand

974cgStrCat x y = do

979cgStrCat x y = do

@@ -994,50 +999,50 @@ cgStrCat x y = do

994ibin :: IntTy -> Operand -> Operand

999ibin :: IntTy -> Operand -> Operand

995 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand

1000 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand

996ibin ity x y instCon = do

1001ibin ity x y instCon = do

997− nx <- unbox (FInt ity) x

1002+ nx <- unbox (FArith (ATInt ity)) x

998− ny <- unbox (FInt ity) y

1003+ ny <- unbox (FArith (ATInt ity)) y

999 nr <- inst $ instCon nx ny []

1004 nr <- inst $ instCon nx ny []

1000− box (FInt ity) nr

1005+ box (FArith (ATInt ity)) nr

1001

1006

1002iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand

1007iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand

1003iun ity x instCon = do

1008iun ity x instCon = do

1004− nx <- unbox (FInt ity) x

1009+ nx <- unbox (FArith (ATInt ity)) x

1005 nr <- inst $ instCon nx []

1010 nr <- inst $ instCon nx []

1006− box (FInt ity) nr

1011+ box (FArith (ATInt ity)) nr

1007

1012

1008iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand

1013iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand

1009iCmp ity pred x y = do

1014iCmp ity pred x y = do

1010− nx <- unbox (FInt ity) x

1015+ nx <- unbox (FArith (ATInt ity)) x

1011− ny <- unbox (FInt ity) y

1016+ ny <- unbox (FArith (ATInt ity)) y

1012 nr <- inst $ ICmp pred nx ny []

1017 nr <- inst $ ICmp pred nx ny []

1013 nr' <- inst $ ZExt nr (IntegerType 32) []

1018 nr' <- inst $ ZExt nr (IntegerType 32) []

1014− box (FInt IT32) nr'

1019+ box (FArith (ATInt (ITFixed IT32))) nr'

1015

1020

1016mpzBin :: String -> Operand -> Operand -> Codegen Operand

1021mpzBin :: String -> Operand -> Operand -> Codegen Operand

1017mpzBin name x y = do

1022mpzBin name x y = do

1018− nx <- unbox (FInt ITBig) x

1023+ nx <- unbox (FArith (ATInt ITBig)) x

1019− ny <- unbox (FInt ITBig) y

1024+ ny <- unbox (FArith (ATInt ITBig)) y

1020 nz <- alloc mpzTy

1025 nz <- alloc mpzTy

1021 inst' $ simpleCall "__gmpz_init" [nz]

1026 inst' $ simpleCall "__gmpz_init" [nz]

1022 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]

1027 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]

1023− box (FInt ITBig) nz

1028+ box (FArith (ATInt ITBig)) nz

1024

1029

1025mpzUn :: String -> Operand -> Codegen Operand

1030mpzUn :: String -> Operand -> Codegen Operand

1026mpzUn name x = do

1031mpzUn name x = do

1027− nx <- unbox (FInt ITBig) x

1032+ nx <- unbox (FArith (ATInt ITBig)) x

1028 nz <- alloc mpzTy

1033 nz <- alloc mpzTy

1029 inst' $ simpleCall "__gmpz_init" [nz]

1034 inst' $ simpleCall "__gmpz_init" [nz]

1030 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]

1035 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]

1031− box (FInt ITBig) nz

1036+ box (FArith (ATInt ITBig)) nz

1032

1037

1033mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand

1038mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand

1034mpzCmp pred x y = do

1039mpzCmp pred x y = do

1035− nx <- unbox (FInt ITBig) x

1040+ nx <- unbox (FArith (ATInt ITBig)) x

1036− ny <- unbox (FInt ITBig) y

1041+ ny <- unbox (FArith (ATInt ITBig)) y

1037 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]

1042 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]

1038 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []

1043 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []

1039 i <- inst $ ZExt result (IntegerType 32) []

1044 i <- inst $ ZExt result (IntegerType 32) []

1040− box (FInt IT32) i

1045+ box (FArith (ATInt (ITFixed IT32))) i

1041

1046

1042simpleCall :: String -> [Operand] -> Instruction

1047simpleCall :: String -> [Operand] -> Instruction

1043simpleCall name args =

1048simpleCall name args =

src/IRTS/Compiler.hs+12−12

@@ -299,7 +299,7 @@ mkIty' _ = FAny

299-- would be better if these FInt types were evaluated at compile time

300-- TODO: add %eval directive for such things

301

302−mkIty "FFloat" = FDouble

302+mkIty "FFloat" = FArith ATFloat

303mkIty "FInt" = mkIntIty "ITNative"

304mkIty "FChar" = mkIntIty "IT8"

305mkIty "FShort" = mkIntIty "IT16"

@@ -311,11 +311,11 @@ mkIty "FFunction" = FFunction

311mkIty "FFunctionIO" = FFunctionIO

312mkIty x = error $ "Unknown type " ++ x

313

314−mkIntIty "ITNative" = FInt ITNative

314+mkIntIty "ITNative" = FArith (ATInt ITNative)

315−mkIntIty "IT8" = FInt IT8

315+mkIntIty "IT8" = FArith (ATInt (ITFixed IT8))

316−mkIntIty "IT16" = FInt IT16

316+mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))

317−mkIntIty "IT32" = FInt IT32

317+mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))

318−mkIntIty "IT64" = FInt IT64

318+mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))

319

320zname = NS (UN "O") ["Nat","Prelude"]

321sname = NS (UN "S") ["Nat","Prelude"]

@@ -369,15 +369,15 @@ instance ToIR SC where

369 matchable (Str _) = True

370 matchable _ = False

371

372− matchableTy IType = True

372+ matchableTy (AType (ATInt ITNative)) = True

373− matchableTy BIType = True

373+ matchableTy (AType (ATInt ITBig)) = True

374 matchableTy ChType = True

375 matchableTy StrType = True

376

377− matchableTy B8Type = True

377+ matchableTy (AType (ATInt (ITFixed IT8))) = True

378− matchableTy B16Type = True

378+ matchableTy (AType (ATInt (ITFixed IT16))) = True

379− matchableTy B32Type = True

379+ matchableTy (AType (ATInt (ITFixed IT32))) = True

380− matchableTy B64Type = True

380+ matchableTy (AType (ATInt (ITFixed IT64))) = True

381

382 matchableTy _ = False

383

src/IRTS/LParser.hs+29−29

@@ -92,39 +92,39 @@ pLDecl = do reserved "data"

93pLExp = buildExpressionParser optable pLExp'

95−optable = [[binary "*" (\x y -> LOp (LTimes ITNative) [x,y]) AssocLeft,

95+optable = [[binary "*" (\x y -> LOp (LTimes (ATInt ITNative)) [x,y]) AssocLeft,

96− binary "/" (\x y -> LOp (LSDiv ITNative) [x,y]) AssocLeft,

96+ binary "/" (\x y -> LOp (LSDiv (ATInt ITNative)) [x,y]) AssocLeft,

97− binary "*." (\x y -> LOp LFTimes [x,y]) AssocLeft,

97+ binary "*." (\x y -> LOp (LTimes ATFloat) [x,y]) AssocLeft,

98− binary "/." (\x y -> LOp LFDiv [x,y]) AssocLeft,

98+ binary "/." (\x y -> LOp (LSDiv ATFloat) [x,y]) AssocLeft,

99− binary "*:" (\x y -> LOp (LTimes ITBig) [x,y]) AssocLeft,

99+ binary "*:" (\x y -> LOp (LTimes (ATInt ITBig)) [x,y]) AssocLeft,

100− binary "/:" (\x y -> LOp (LSDiv ITBig) [x,y]) AssocLeft

100+ binary "/:" (\x y -> LOp (LSDiv (ATInt ITBig)) [x,y]) AssocLeft

101 ],

102 [

103− binary "+" (\x y -> LOp (LPlus ITNative) [x,y]) AssocLeft,

103+ binary "+" (\x y -> LOp (LPlus (ATInt ITNative)) [x,y]) AssocLeft,

104− binary "-" (\x y -> LOp (LMinus ITNative) [x,y]) AssocLeft,

104+ binary "-" (\x y -> LOp (LMinus (ATInt ITNative)) [x,y]) AssocLeft,

105 binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft,

106− binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft,

106+ binary "+." (\x y -> LOp (LPlus ATFloat) [x,y]) AssocLeft,

107− binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft,

107+ binary "-." (\x y -> LOp (LMinus ATFloat) [x,y]) AssocLeft,

108− binary "+:" (\x y -> LOp (LPlus ITBig) [x,y]) AssocLeft,

108+ binary "+:" (\x y -> LOp (LPlus (ATInt ITBig)) [x,y]) AssocLeft,

109− binary "-:" (\x y -> LOp (LMinus ITBig) [x,y]) AssocLeft

109+ binary "-:" (\x y -> LOp (LMinus (ATInt ITBig)) [x,y]) AssocLeft

110 ],

111 [

112− binary "==" (\x y -> LOp (LEq ITNative) [x, y]) AssocNone,

112+ binary "==" (\x y -> LOp (LEq (ATInt ITNative)) [x, y]) AssocNone,

113− binary "==." (\x y -> LOp LFEq [x, y]) AssocNone,

113+ binary "==." (\x y -> LOp (LEq ATFloat) [x, y]) AssocNone,

114− binary "<" (\x y -> LOp (LLt ITNative) [x, y]) AssocNone,

114+ binary "<" (\x y -> LOp (LLt (ATInt ITNative)) [x, y]) AssocNone,

115− binary "<." (\x y -> LOp LFLt [x, y]) AssocNone,

115+ binary "<." (\x y -> LOp (LLt ATFloat) [x, y]) AssocNone,

116− binary ">" (\x y -> LOp (LGt ITNative) [x, y]) AssocNone,

116+ binary ">" (\x y -> LOp (LGt (ATInt ITNative)) [x, y]) AssocNone,

117− binary ">." (\x y -> LOp LFGt [x, y]) AssocNone,

117+ binary ">." (\x y -> LOp (LGt ATFloat) [x, y]) AssocNone,

118− binary "<=" (\x y -> LOp (LLe ITNative) [x, y]) AssocNone,

118+ binary "<=" (\x y -> LOp (LLe (ATInt ITNative)) [x, y]) AssocNone,

119− binary "<=." (\x y -> LOp LFLe [x, y]) AssocNone,

119+ binary "<=." (\x y -> LOp (LLe ATFloat) [x, y]) AssocNone,

120− binary ">=" (\x y -> LOp (LGe ITNative) [x, y]) AssocNone,

120+ binary ">=" (\x y -> LOp (LGe (ATInt ITNative)) [x, y]) AssocNone,

121− binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone,

121+ binary ">=." (\x y -> LOp (LGe ATFloat) [x, y]) AssocNone,

122

123− binary "==:" (\x y -> LOp (LEq ITBig) [x, y]) AssocNone,

123+ binary "==:" (\x y -> LOp (LEq (ATInt ITBig)) [x, y]) AssocNone,

124− binary "<:" (\x y -> LOp (LLt ITBig) [x, y]) AssocNone,

124+ binary "<:" (\x y -> LOp (LLt (ATInt ITBig)) [x, y]) AssocNone,

125− binary ">:" (\x y -> LOp (LGt ITBig) [x, y]) AssocNone,

125+ binary ">:" (\x y -> LOp (LGt (ATInt ITBig)) [x, y]) AssocNone,

126− binary "<=:" (\x y -> LOp (LLe ITBig) [x, y]) AssocNone,

126+ binary "<=:" (\x y -> LOp (LLe (ATInt ITBig)) [x, y]) AssocNone,

127− binary ">=:" (\x y -> LOp (LGe ITBig) [x, y]) AssocNone

127+ binary ">=:" (\x y -> LOp (LGe (ATInt ITBig)) [x, y]) AssocNone

128 ]]

129

130binary name f assoc = Infix (do reservedOp name; return f) assoc

@@ -164,8 +164,8 @@ pLExp' = try (do lchar '%'; pCast)

164

165pLang = do reserved "C"; return LANG_C

166

167−pType = do reserved "Int"; return (FInt ITNative)

167+pType = do reserved "Int"; return (FArith (ATInt ITNative))

168− <|> do reserved "Float"; return FDouble

168+ <|> do reserved "Float"; return (FArith ATFloat)

169 <|> do reserved "String"; return FString

170 <|> do reserved "Unit"; return FUnit

171 <|> do reserved "Ptr"; return FPtr

src/IRTS/Lang.hs+6−27

@@ -3,7 +3,6 @@ module IRTS.Lang where

3import Core.TT

4import Control.Monad.State hiding(lift)

5import Data.List

6−import Foreign.Storable (sizeOf)

7import Debug.Trace

6import Debug.Trace

9data LVar = Loc Int | Glob Name

8data LVar = Loc Int | Glob Name

@@ -29,33 +28,12 @@ data LExp = LV LVar

29-- Primitive operators. Backends are not *required* to implement all

28-- Primitive operators. Backends are not *required* to implement all

30-- of these, but should report an error if they are unable

29-- of these, but should report an error if they are unable

32−data IntTy = ITNative | IT8 | IT16 | IT32 | IT64 | ITBig

33− deriving (Show, Eq)

34−

35−intTyWidth :: IntTy -> Int

36−intTyWidth IT8 = 8

37−intTyWidth IT16 = 16

38−intTyWidth IT32 = 32

39−intTyWidth IT64 = 64

40−intTyWidth ITNative = 8 * sizeOf (0 :: Int)

41−intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width"

42−

43−intTyToConst :: IntTy -> Const

44−intTyToConst IT8 = B8Type

45−intTyToConst IT16 = B16Type

46−intTyToConst IT32 = B32Type

47−intTyToConst IT64 = B64Type

48−intTyToConst ITBig = BIType

49−intTyToConst ITNative = IType

50−

51−data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy

31+data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy

52− | LUDiv IntTy | LSDiv IntTy | LURem IntTy | LSRem IntTy

32+ | LUDiv IntTy | LSDiv ArithTy | LURem IntTy | LSRem ArithTy

53 | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy

33 | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy

54 | LSHL IntTy | LLSHR IntTy | LASHR IntTy

34 | LSHL IntTy | LLSHR IntTy | LASHR IntTy

56 | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy

36 | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy

57− | LFPlus | LFMinus | LFTimes | LFDiv

59 | LStrConcat | LStrLt | LStrEq | LStrLen

37 | LStrConcat | LStrLt | LStrEq | LStrLen

60 | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy

38 | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy

61 | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy

39 | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy

@@ -64,6 +42,8 @@ data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy

65 | LFSqrt | LFFloor | LFCeil

43 | LFSqrt | LFFloor | LFCeil

45+ | LMkVec NativeTy Int

46+

68 | LStdIn | LStdOut | LStdErr

48 | LStdIn | LStdOut | LStdErr

@@ -79,14 +59,13 @@ data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy

79data FLang = LANG_C

59data FLang = LANG_C

80 deriving (Show, Eq)

60 deriving (Show, Eq)

82−data FType = FInt IntTy

62+data FType = FArith ArithTy

83 | FFunction

63 | FFunction

84 | FFunctionIO

64 | FFunctionIO

85 | FChar

65 | FChar

86 | FString

66 | FString

87 | FUnit

67 | FUnit

88 | FPtr

68 | FPtr

89− | FDouble

90 | FAny

69 | FAny

91 deriving (Show, Eq)

70 deriving (Show, Eq)

src/Idris/ElabDecls.hs+1−1

@@ -1174,7 +1174,7 @@ elabInstance info syn fc cs n ps t expn ds

1174-- mapM_ (elabDecl EAll info) (concat fns)

1175 where

1176 intInst = case ps of

1177− [PConstant IType] -> True

1177+ [PConstant (AType (ATInt ITNative))] -> True

1178 _ -> False

1179

1180 checkNotOverlapping i t n

src/Idris/ElabTerm.hs+15−15

@@ -653,7 +653,7 @@ resolveTC depth fn ist

653

654 needsDefault t num@(P _ (NS (UN "Num") ["Builtins"]) _) [P Bound a _]

655 = do focus a

656− fill (RConstant IType) -- default Int

656+ fill (RConstant (AType (ATInt ITNative))) -- default Int

657 solve

658 return False

659 needsDefault t f as

@@ -1060,15 +1060,15 @@ reifyTTBinderApp reif f [t]

1060reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args))

1061

1062reifyTTConst :: Term -> ElabD Const

1063−reifyTTConst (P _ n _) | n == reflm "IType" = return $ IType

1063+reifyTTConst (P _ n _) | n == reflm "IType" = return (AType (ATInt ITNative))

1064−reifyTTConst (P _ n _) | n == reflm "BIType" = return $ BIType

1064+reifyTTConst (P _ n _) | n == reflm "BIType" = return (AType (ATInt ITBig))

1065−reifyTTConst (P _ n _) | n == reflm "FlType" = return $ FlType

1065+reifyTTConst (P _ n _) | n == reflm "FlType" = return (AType ATFloat)

1066reifyTTConst (P _ n _) | n == reflm "ChType" = return $ ChType

1067reifyTTConst (P _ n _) | n == reflm "StrType" = return $ StrType

1068−reifyTTConst (P _ n _) | n == reflm "B8Type" = return $ B8Type

1068+reifyTTConst (P _ n _) | n == reflm "B8Type" = return (AType (ATInt (ITFixed IT8)))

1069−reifyTTConst (P _ n _) | n == reflm "B16Type" = return $ B16Type

1069+reifyTTConst (P _ n _) | n == reflm "B16Type" = return (AType (ATInt (ITFixed IT16)))

1070−reifyTTConst (P _ n _) | n == reflm "B32Type" = return $ B32Type

1070+reifyTTConst (P _ n _) | n == reflm "B32Type" = return (AType (ATInt (ITFixed IT32)))

1071−reifyTTConst (P _ n _) | n == reflm "B64Type" = return $ B64Type

1071+reifyTTConst (P _ n _) | n == reflm "B64Type" = return (AType (ATInt (ITFixed IT64)))

1072reifyTTConst (P _ n _) | n == reflm "PtrType" = return $ PtrType

1073reifyTTConst (P _ n _) | n == reflm "VoidType" = return $ VoidType

1074reifyTTConst (P _ n _) | n == reflm "Forgot" = return $ Forgot

@@ -1178,19 +1178,19 @@ reflectConstant c@(BI _) = reflCall "BI" [RConstant c]

1178reflectConstant c@(Fl _) = reflCall "Fl" [RConstant c]

1179reflectConstant c@(Ch _) = reflCall "Ch" [RConstant c]

1180reflectConstant c@(Str _) = reflCall "Str" [RConstant c]

1181−reflectConstant (IType) = Var (reflm "IType")

1181+reflectConstant (AType (ATInt ITNative)) = Var (reflm "IType")

1182−reflectConstant (BIType) = Var (reflm "BIType")

1182+reflectConstant (AType (ATInt ITBig)) = Var (reflm "BIType")

1183−reflectConstant (FlType) = Var (reflm "FlType")

1183+reflectConstant (AType ATFloat) = Var (reflm "FlType")

1184reflectConstant (ChType) = Var (reflm "ChType")

1185reflectConstant (StrType) = Var (reflm "StrType")

1186reflectConstant c@(B8 _) = reflCall "B8" [RConstant c]

1187reflectConstant c@(B16 _) = reflCall "B16" [RConstant c]

1188reflectConstant c@(B32 _) = reflCall "B32" [RConstant c]

1189reflectConstant c@(B64 _) = reflCall "B64" [RConstant c]

1190−reflectConstant (B8Type) = Var (reflm "B8Type")

1190+reflectConstant (AType (ATInt (ITFixed IT8))) = Var (reflm "B8Type")

1191−reflectConstant (B16Type) = Var (reflm "B16Type")

1191+reflectConstant (AType (ATInt (ITFixed IT16))) = Var (reflm "B16Type")

1192−reflectConstant (B32Type) = Var (reflm "B32Type")

1192+reflectConstant (AType (ATInt (ITFixed IT32))) = Var (reflm "B32Type")

1193−reflectConstant (B64Type) = Var (reflm "B64Type")

1193+reflectConstant (AType (ATInt (ITFixed IT64))) = Var (reflm "B64Type")

1194reflectConstant (PtrType) = Var (reflm "PtrType")

1195reflectConstant (VoidType) = Var (reflm "VoidType")

1196reflectConstant (Forgot) = Var (reflm "Forgot")

src/Idris/IBC.hs+21−15

@@ -364,7 +364,7 @@ instance Binary Name where

364 3 -> return NErased

365 _ -> error "Corrupted binary data for Name"

366

367−

367+

368instance Binary Const where

369 put x

370 = case x of

@@ -383,17 +383,18 @@ instance Binary Const where

383 B32 x1 -> putWord8 7 >> put x1

384 B64 x1 -> putWord8 8 >> put x1

385

386− IType -> putWord8 9

386+ (AType (ATInt ITNative)) -> putWord8 9

387− BIType -> putWord8 10

387+ (AType (ATInt ITBig)) -> putWord8 10

388− FlType -> putWord8 11

388+ (AType ATFloat) -> putWord8 11

389 ChType -> putWord8 12

390 StrType -> putWord8 13

391 PtrType -> putWord8 14

392 Forgot -> putWord8 15

393− B8Type -> putWord8 16

393+ (AType (ATInt (ITFixed ity))) -> put (16 + fromEnum ity) -- 16-19 inclusive

394− B16Type -> putWord8 17

394+ (AType (ATInt (ITVec ity count))) -> do

395− B32Type -> putWord8 18

395+ putWord8 20

396− B64Type -> putWord8 19

396+ putWord8 (fromIntegral . fromEnum $ ity)

397+ putWord8 (fromIntegral count)

397 get

398 get

398 = do i <- getWord8

399 = do i <- getWord8

399 case i of

400 case i of

@@ -412,18 +413,23 @@ instance Binary Const where

412 7 -> fmap B32 get

413 7 -> fmap B32 get

413 8 -> fmap B64 get

414 8 -> fmap B64 get

414

415

415− 9 -> return IType

416+ 9 -> return (AType (ATInt ITNative))

416− 10 -> return BIType

417+ 10 -> return (AType (ATInt ITBig))

417− 11 -> return FlType

418+ 11 -> return (AType ATFloat)

418 12 -> return ChType

419 12 -> return ChType

419 13 -> return StrType

420 13 -> return StrType

420 14 -> return PtrType

421 14 -> return PtrType

421 15 -> return Forgot

422 15 -> return Forgot

422

423

423− 16 -> return B8Type

424+ 16 -> return (AType (ATInt (ITFixed IT8)))

424− 17 -> return B16Type

425+ 17 -> return (AType (ATInt (ITFixed IT16)))

425− 18 -> return B32Type

426+ 18 -> return (AType (ATInt (ITFixed IT32)))

426− 19 -> return B64Type

427+ 19 -> return (AType (ATInt (ITFixed IT64)))

428+

429+ 20 -> do

430+ e <- getWord8

431+ c <- getWord8

432+ return (AType (ATInt (ITVec (toEnum . fromIntegral $ e) (fromIntegral c))))

427

433

428 _ -> error "Corrupted binary data for Const"

434 _ -> error "Corrupted binary data for Const"

429

435

src/Idris/Parser.hs+7−7

@@ -1139,16 +1139,16 @@ pIdiom syn

1139 return (PIdiom fc e)

1140

1141pConstant :: IParser Const

1142−pConstant = do reserved "Integer";return BIType

1142+pConstant = do reserved "Integer";return (AType (ATInt ITBig))

1143− <|> do reserved "Int"; return IType

1143+ <|> do reserved "Int"; return (AType (ATInt ITNative))

1144 <|> do reserved "Char"; return ChType

1145− <|> do reserved "Float"; return FlType

1145+ <|> do reserved "Float"; return (AType ATFloat)

1146 <|> do reserved "String"; return StrType

1147 <|> do reserved "Ptr"; return PtrType

1148− <|> do reserved "Bits8"; return B8Type

1148+ <|> do reserved "Bits8"; return (AType (ATInt (ITFixed IT8)))

1149− <|> do reserved "Bits16"; return B16Type

1149+ <|> do reserved "Bits16"; return (AType (ATInt (ITFixed IT16)))

1150− <|> do reserved "Bits32"; return B32Type

1150+ <|> do reserved "Bits32"; return (AType (ATInt (ITFixed IT32)))

1151− <|> do reserved "Bits64"; return B64Type

1151+ <|> do reserved "Bits64"; return (AType (ATInt (ITFixed IT64)))

1152 <|> try (do f <- float; return $ Fl f)

1153 <|> try (do i <- natural; return $ BI i)

1154 <|> try (do s <- strlit; return $ Str s)

src/Idris/Primitives.hs+197−168

@@ -11,6 +11,7 @@ import Core.Evaluate

11import Data.Bits

12import Data.Word

13import Data.Int

14+import qualified Data.Vector.Unboxed as V

15data Prim = Prim { p_name :: Name,

16data Prim = Prim { p_name :: Name,

16 p_type :: Type,

17 p_type :: Type,

@@ -31,130 +32,130 @@ partial = Partial NotCovering

31primitives :: [Prim]

32primitives :: [Prim]

32primitives =

33primitives =

33 -- operators

34 -- operators

34− [Prim (UN "prim__eqChar") (ty [ChType, ChType] IType) 2 (bcBin (==))

35+ [Prim (UN "prim__eqChar") (ty [ChType, ChType] (AType (ATInt ITNative))) 2 (bcBin (==))

35− (2, LEq ITNative) total,

36+ (2, LEq (ATInt ITNative)) total,

36− Prim (UN "prim__ltChar") (ty [ChType, ChType] IType) 2 (bcBin (<))

37+ Prim (UN "prim__ltChar") (ty [ChType, ChType] (AType (ATInt ITNative))) 2 (bcBin (<))

37− (2, LLt ITNative) total,

38+ (2, LLt (ATInt ITNative)) total,

38− Prim (UN "prim__lteChar") (ty [ChType, ChType] IType) 2 (bcBin (<=))

39+ Prim (UN "prim__lteChar") (ty [ChType, ChType] (AType (ATInt ITNative))) 2 (bcBin (<=))

39− (2, LLe ITNative) total,

40+ (2, LLe (ATInt ITNative)) total,

40− Prim (UN "prim__gtChar") (ty [ChType, ChType] IType) 2 (bcBin (>))

41+ Prim (UN "prim__gtChar") (ty [ChType, ChType] (AType (ATInt ITNative))) 2 (bcBin (>))

41− (2, LGt ITNative) total,

42+ (2, LGt (ATInt ITNative)) total,

42− Prim (UN "prim__gteChar") (ty [ChType, ChType] IType) 2 (bcBin (>=))

43+ Prim (UN "prim__gteChar") (ty [ChType, ChType] (AType (ATInt ITNative))) 2 (bcBin (>=))

43− (2, LGe ITNative) total,

44+ (2, LGe (ATInt ITNative)) total,

44−

45+

45− iCoerce IT8 IT16 "zext" zext LZExt,

46+ iCoerce (ITFixed IT8) (ITFixed IT16) "zext" zext LZExt,

46− iCoerce IT8 IT32 "zext" zext LZExt,

47+ iCoerce (ITFixed IT8) (ITFixed IT32) "zext" zext LZExt,

47− iCoerce IT8 IT64 "zext" zext LZExt,

48+ iCoerce (ITFixed IT8) (ITFixed IT64) "zext" zext LZExt,

48− iCoerce IT8 ITBig "zext" zext LZExt,

49+ iCoerce (ITFixed IT8) ITBig "zext" zext LZExt,

49− iCoerce IT8 ITNative "zext" zext LZExt,

50+ iCoerce (ITFixed IT8) ITNative "zext" zext LZExt,

50− iCoerce IT16 IT32 "zext" zext LZExt,

51+ iCoerce (ITFixed IT16) (ITFixed IT32) "zext" zext LZExt,

51− iCoerce IT16 IT64 "zext" zext LZExt,

52+ iCoerce (ITFixed IT16) (ITFixed IT64) "zext" zext LZExt,

52− iCoerce IT16 ITBig "zext" zext LZExt,

53+ iCoerce (ITFixed IT16) ITBig "zext" zext LZExt,

53− iCoerce IT16 ITNative "zext" zext LZExt,

54+ iCoerce (ITFixed IT16) ITNative "zext" zext LZExt,

54− iCoerce IT32 IT64 "zext" zext LZExt,

55+ iCoerce (ITFixed IT32) (ITFixed IT64) "zext" zext LZExt,

55− iCoerce IT32 ITBig "zext" zext LZExt,

56+ iCoerce (ITFixed IT32) ITBig "zext" zext LZExt,

56− iCoerce IT32 ITNative "zext" zext LZExt,

57+ iCoerce (ITFixed IT32) ITNative "zext" zext LZExt,

57− iCoerce IT64 ITBig "zext" zext LZExt,

58+ iCoerce (ITFixed IT64) ITBig "zext" zext LZExt,

58 iCoerce ITNative ITBig "zext" zext LZExt,

59 iCoerce ITNative ITBig "zext" zext LZExt,

59− iCoerce ITNative IT64 "zext" zext LZExt,

60+ iCoerce ITNative (ITFixed IT64) "zext" zext LZExt,

60− iCoerce ITNative IT32 "zext" zext LZExt,

61+ iCoerce ITNative (ITFixed IT32) "zext" zext LZExt,

61− iCoerce ITNative IT16 "zext" zext LZExt,

62+ iCoerce ITNative (ITFixed IT16) "zext" zext LZExt,

62−

63+

63− iCoerce IT8 IT16 "sext" sext LSExt,

64+ iCoerce (ITFixed IT8) (ITFixed IT16) "sext" sext LSExt,

64− iCoerce IT8 IT32 "sext" sext LSExt,

65+ iCoerce (ITFixed IT8) (ITFixed IT32) "sext" sext LSExt,

65− iCoerce IT8 IT64 "sext" sext LSExt,

66+ iCoerce (ITFixed IT8) (ITFixed IT64) "sext" sext LSExt,

66− iCoerce IT8 ITBig "sext" sext LSExt,

67+ iCoerce (ITFixed IT8) ITBig "sext" sext LSExt,

67− iCoerce IT8 ITNative "sext" sext LSExt,

68+ iCoerce (ITFixed IT8) ITNative "sext" sext LSExt,

68− iCoerce IT16 IT32 "sext" sext LSExt,

69+ iCoerce (ITFixed IT16) (ITFixed IT32) "sext" sext LSExt,

69− iCoerce IT16 IT64 "sext" sext LSExt,

70+ iCoerce (ITFixed IT16) (ITFixed IT64) "sext" sext LSExt,

70− iCoerce IT16 ITBig "sext" sext LSExt,

71+ iCoerce (ITFixed IT16) ITBig "sext" sext LSExt,

71− iCoerce IT16 ITNative "sext" sext LSExt,

72+ iCoerce (ITFixed IT16) ITNative "sext" sext LSExt,

72− iCoerce IT32 IT64 "sext" sext LSExt,

73+ iCoerce (ITFixed IT32) (ITFixed IT64) "sext" sext LSExt,

73− iCoerce IT32 ITBig "sext" sext LSExt,

74+ iCoerce (ITFixed IT32) ITBig "sext" sext LSExt,

74− iCoerce IT32 ITNative "sext" sext LSExt,

75+ iCoerce (ITFixed IT32) ITNative "sext" sext LSExt,

75− iCoerce IT64 ITBig "sext" sext LSExt,

76+ iCoerce (ITFixed IT64) ITBig "sext" sext LSExt,

76 iCoerce ITNative ITBig "sext" sext LSExt,

77 iCoerce ITNative ITBig "sext" sext LSExt,

78 iCoerce ITNative ITBig "sext" sext LSExt,

78− iCoerce ITNative IT64 "sext" sext LSExt,

79+ iCoerce ITNative (ITFixed IT64) "sext" sext LSExt,

79− iCoerce ITNative IT32 "sext" sext LSExt,

80+ iCoerce ITNative (ITFixed IT32) "sext" sext LSExt,

80− iCoerce ITNative IT16 "sext" sext LSExt,

81+ iCoerce ITNative (ITFixed IT16) "sext" sext LSExt,

81−

82+

82− iCoerce IT16 IT8 "trunc" trunc LTrunc,

83+ iCoerce (ITFixed IT16) (ITFixed IT8) "trunc" trunc LTrunc,

83− iCoerce IT32 IT8 "trunc" trunc LTrunc,

84+ iCoerce (ITFixed IT32) (ITFixed IT8) "trunc" trunc LTrunc,

84− iCoerce IT64 IT8 "trunc" trunc LTrunc,

85+ iCoerce (ITFixed IT64) (ITFixed IT8) "trunc" trunc LTrunc,

85− iCoerce ITBig IT8 "trunc" trunc LTrunc,

86+ iCoerce ITBig (ITFixed IT8) "trunc" trunc LTrunc,

86− iCoerce ITNative IT8 "trunc" trunc LTrunc,

87+ iCoerce ITNative (ITFixed IT8) "trunc" trunc LTrunc,

87− iCoerce IT32 IT16 "trunc" trunc LTrunc,

88+ iCoerce (ITFixed IT32) (ITFixed IT16) "trunc" trunc LTrunc,

88− iCoerce IT64 IT16 "trunc" trunc LTrunc,

89+ iCoerce (ITFixed IT64) (ITFixed IT16) "trunc" trunc LTrunc,

89− iCoerce ITBig IT16 "trunc" trunc LTrunc,

90+ iCoerce ITBig (ITFixed IT16) "trunc" trunc LTrunc,

90− iCoerce ITNative IT16 "trunc" trunc LTrunc,

91+ iCoerce ITNative (ITFixed IT16) "trunc" trunc LTrunc,

91− iCoerce IT64 IT32 "trunc" trunc LTrunc,

92+ iCoerce (ITFixed IT64) (ITFixed IT32) "trunc" trunc LTrunc,

92− iCoerce ITBig IT32 "trunc" trunc LTrunc,

93+ iCoerce ITBig (ITFixed IT32) "trunc" trunc LTrunc,

93− iCoerce ITNative IT32 "trunc" trunc LTrunc,

94+ iCoerce ITNative (ITFixed IT32) "trunc" trunc LTrunc,

94− iCoerce ITBig IT64 "trunc" trunc LTrunc,

95+ iCoerce ITBig (ITFixed IT64) "trunc" trunc LTrunc,

95− iCoerce IT16 ITNative "trunc" trunc LTrunc,

96+ iCoerce (ITFixed IT16) ITNative "trunc" trunc LTrunc,

96− iCoerce IT32 ITNative "trunc" trunc LTrunc,

97+ iCoerce (ITFixed IT32) ITNative "trunc" trunc LTrunc,

97− iCoerce IT64 ITNative "trunc" trunc LTrunc,

98+ iCoerce (ITFixed IT64) ITNative "trunc" trunc LTrunc,

98 iCoerce ITBig ITNative "trunc" trunc LTrunc,

99 iCoerce ITBig ITNative "trunc" trunc LTrunc,

99− iCoerce ITNative IT64 "trunc" trunc LTrunc,

100+ iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc,

100−

101+

101− Prim (UN "prim__addFloat") (ty [FlType, FlType] FlType) 2 (fBin (+))

102+ Prim (UN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))

102− (2, LFPlus) total,

103+ (2, LPlus ATFloat) total,

103− Prim (UN "prim__subFloat") (ty [FlType, FlType] FlType) 2 (fBin (-))

104+ Prim (UN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))

104− (2, LFMinus) total,

105+ (2, LMinus ATFloat) total,

105− Prim (UN "prim__mulFloat") (ty [FlType, FlType] FlType) 2 (fBin (*))

106+ Prim (UN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))

106− (2, LFTimes) total,

107+ (2, LTimes ATFloat) total,

107− Prim (UN "prim__divFloat") (ty [FlType, FlType] FlType) 2 (fBin (/))

108+ Prim (UN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))

108− (2, LFDiv) total,

109+ (2, LSDiv ATFloat) total,

109− Prim (UN "prim__eqFloat") (ty [FlType, FlType] IType) 2 (bfBin (==))

110+ Prim (UN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))

110− (2, LFEq) total,

111+ (2, LEq ATFloat) total,

111− Prim (UN "prim__ltFloat") (ty [FlType, FlType] IType) 2 (bfBin (<))

112+ Prim (UN "prim__ltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))

112− (2, LFLt) total,

113+ (2, LLt ATFloat) total,

113− Prim (UN "prim__lteFloat") (ty [FlType, FlType] IType) 2 (bfBin (<=))

114+ Prim (UN "prim__lteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))

114− (2, LFLe) total,

115+ (2, LLe ATFloat) total,

115− Prim (UN "prim__gtFloat") (ty [FlType, FlType] IType) 2 (bfBin (>))

116+ Prim (UN "prim__gtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))

116− (2, LFGt) total,

117+ (2, LGt ATFloat) total,

117− Prim (UN "prim__gteFloat") (ty [FlType, FlType] IType) 2 (bfBin (>=))

118+ Prim (UN "prim__gteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))

118− (2, LFGe) total,

119+ (2, LGe ATFloat) total,

119 Prim (UN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))

120 Prim (UN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))

120 (2, LStrConcat) total,

121 (2, LStrConcat) total,

121− Prim (UN "prim__eqString") (ty [StrType, StrType] IType) 2 (bsBin (==))

122+ Prim (UN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))

122 (2, LStrEq) total,

123 (2, LStrEq) total,

123− Prim (UN "prim__ltString") (ty [StrType, StrType] IType) 2 (bsBin (<))

124+ Prim (UN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))

124 (2, LStrLt) total,

125 (2, LStrLt) total,

125− Prim (UN "prim_lenString") (ty [StrType] IType) 1 (p_strLen)

126+ Prim (UN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)

126 (1, LStrLen) total,

127 (1, LStrLen) total,

127 -- Conversions

128 -- Conversions

128− Prim (UN "prim__charToInt") (ty [ChType] IType) 1 (c_charToInt)

129+ Prim (UN "prim__charToInt") (ty [ChType] (AType (ATInt ITNative))) 1 (c_charToInt)

129 (1, LChInt ITNative) total,

130 (1, LChInt ITNative) total,

130− Prim (UN "prim__intToChar") (ty [IType] ChType) 1 (c_intToChar)

131+ Prim (UN "prim__intToChar") (ty [(AType (ATInt ITNative))] ChType) 1 (c_intToChar)

131 (1, LIntCh ITNative) total,

132 (1, LIntCh ITNative) total,

132− Prim (UN "prim__strToFloat") (ty [StrType] FlType) 1 (c_strToFloat)

133+ Prim (UN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)

133 (1, LStrFloat) total,

134 (1, LStrFloat) total,

134− Prim (UN "prim__floatToStr") (ty [FlType] StrType) 1 (c_floatToStr)

135+ Prim (UN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)

135 (1, LFloatStr) total,

136 (1, LFloatStr) total,

136

137

137− Prim (UN "prim__floatExp") (ty [FlType] FlType) 1 (p_floatExp)

138+ Prim (UN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)

138− (1, LFExp) total,

139+ (1, LFExp) total,

139− Prim (UN "prim__floatLog") (ty [FlType] FlType) 1 (p_floatLog)

140+ Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)

140 (1, LFLog) total,

141 (1, LFLog) total,

141− Prim (UN "prim__floatSin") (ty [FlType] FlType) 1 (p_floatSin)

142+ Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)

142 (1, LFSin) total,

143 (1, LFSin) total,

143− Prim (UN "prim__floatCos") (ty [FlType] FlType) 1 (p_floatCos)

144+ Prim (UN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)

144 (1, LFCos) total,

145 (1, LFCos) total,

145− Prim (UN "prim__floatTan") (ty [FlType] FlType) 1 (p_floatTan)

146+ Prim (UN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)

146 (1, LFTan) total,

147 (1, LFTan) total,

147− Prim (UN "prim__floatASin") (ty [FlType] FlType) 1 (p_floatASin)

148+ Prim (UN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)

148 (1, LFASin) total,

149 (1, LFASin) total,

149− Prim (UN "prim__floatACos") (ty [FlType] FlType) 1 (p_floatACos)

150+ Prim (UN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)

150 (1, LFACos) total,

151 (1, LFACos) total,

151− Prim (UN "prim__floatATan") (ty [FlType] FlType) 1 (p_floatATan)

152+ Prim (UN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)

152 (1, LFATan) total,

153 (1, LFATan) total,

153− Prim (UN "prim__floatSqrt") (ty [FlType] FlType) 1 (p_floatSqrt)

154+ Prim (UN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)

154 (1, LFSqrt) total,

155 (1, LFSqrt) total,

155− Prim (UN "prim__floatFloor") (ty [FlType] FlType) 1 (p_floatFloor)

156+ Prim (UN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)

156 (1, LFFloor) total,

157 (1, LFFloor) total,

157− Prim (UN "prim__floatCeil") (ty [FlType] FlType) 1 (p_floatCeil)

158+ Prim (UN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)

158 (1, LFCeil) total,

159 (1, LFCeil) total,

159

160

160 Prim (UN "prim__strHead") (ty [StrType] ChType) 1 (p_strHead)

161 Prim (UN "prim__strHead") (ty [StrType] ChType) 1 (p_strHead)

@@ -163,7 +164,7 @@ primitives =

163 (1, LStrTail) partial,

164 (1, LStrTail) partial,

164 Prim (UN "prim__strCons") (ty [ChType, StrType] StrType) 2 (p_strCons)

165 Prim (UN "prim__strCons") (ty [ChType, StrType] StrType) 2 (p_strCons)

165 (2, LStrCons) total,

166 (2, LStrCons) total,

166− Prim (UN "prim__strIndex") (ty [StrType, IType] ChType) 2 (p_strIndex)

167+ Prim (UN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] ChType) 2 (p_strIndex)

167 (2, LStrIndex) partial,

168 (2, LStrIndex) partial,

168 Prim (UN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)

169 Prim (UN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)

169 (1, LStrRev) total,

170 (1, LStrRev) total,

@@ -174,22 +175,23 @@ primitives =

174 -- Streams

175 -- Streams

175 Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

176 Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

176 (0, LStdIn) partial

177 (0, LStdIn) partial

177− ] ++ concatMap intOps [IT8, IT16, IT32, IT64, ITBig, ITNative]

178+ ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative]

179+ ++ concatMap vecOps [ITVec IT8 16, ITVec IT16 8, ITVec IT32 4, ITVec IT64 2]

178

180

179intOps :: IntTy -> [Prim]

181intOps :: IntTy -> [Prim]

180intOps ity =

182intOps ity =

181− [ iCmp ity "lt" (bCmp ity (<)) LLt total

183+ [ iCmp ity "lt" (bCmp ity (<)) (LLt . ATInt) total

182− , iCmp ity "lte" (bCmp ity (<=)) LLe total

184+ , iCmp ity "lte" (bCmp ity (<=)) (LLe . ATInt) total

183− , iCmp ity "eq" (bCmp ity (==)) LEq total

185+ , iCmp ity "eq" (bCmp ity (==)) (LEq . ATInt) total

184− , iCmp ity "gte" (bCmp ity (>=)) LGe total

186+ , iCmp ity "gte" (bCmp ity (>=)) (LGe . ATInt) total

185− , iCmp ity "gt" (bCmp ity (>)) LGt total

187+ , iCmp ity "gt" (bCmp ity (>)) (LGt . ATInt) total

186− , iBinOp ity "add" (bitBin ity (+)) LPlus total

188+ , iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total

187− , iBinOp ity "sub" (bitBin ity (-)) LMinus total

189+ , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total

188− , iBinOp ity "mul" (bitBin ity (*)) LTimes total

190+ , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total

189 , iBinOp ity "udiv" (bitBin ity div) LUDiv partial

191 , iBinOp ity "udiv" (bitBin ity div) LUDiv partial

190− , iBinOp ity "sdiv" (bsdiv ity) LSDiv partial

192+ , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial

191 , iBinOp ity "urem" (bitBin ity rem) LURem partial

193 , iBinOp ity "urem" (bitBin ity rem) LURem partial

192− , iBinOp ity "srem" (bsrem ity) LSRem partial

194+ , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial

193 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total

195 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total

194 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total

196 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total

195 , iBinOp ity "ashr" (bashr ity) LASHR total

197 , iBinOp ity "ashr" (bashr ity) LASHR total

@@ -197,30 +199,57 @@ intOps ity =

197 , iBinOp ity "or" (bitBin ity (.|.)) LOr total

199 , iBinOp ity "or" (bitBin ity (.|.)) LOr total

198 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total

200 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total

199 , iUnOp ity "compl" (bUn ity complement) LCompl total

201 , iUnOp ity "compl" (bUn ity complement) LCompl total

200− , Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [intTyToConst ity] StrType) 1 intToStr

202+ , Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr

201 (1, LIntStr ity) total

203 (1, LIntStr ity) total

202− , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (intTyToConst ity)) 1 (strToInt ity)

204+ , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)

203 (1, LStrInt ity) total

205 (1, LStrInt ity) total

204− , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [intTyToConst ity] FlType) 1 intToFloat

206+ , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat

205 (1, LIntFloat ity) total

207 (1, LIntFloat ity) total

206− , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [FlType] (intTyToConst ity)) 1 (floatToInt ity)

208+ , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)

207 (1, LFloatInt ity) total

209 (1, LFloatInt ity) total

208 ]

210 ]

209

211

212+vecOps ity@(ITVec elem count) =

213+ [ Prim (UN $ "prim__mk" ++ intTyName ity)

214+ (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))

215+ count (mkVecCon elem count) (count, LMkVec elem count) total

216+ ]

217+

218+mkVecCon ity count args = if length ints == count

219+ then Just (mkVec ity count ints)

220+ else error $ "Got: " ++ show args ++ " when expecting " ++ show count ++ " x " ++ show ity

221+ where

222+ ints = getInt args

223+ mkVec :: NativeTy -> Int -> [Integer] -> Const

224+ mkVec IT8 len values = B8V $ V.generate len (fromInteger . (values !!))

225+ mkVec IT16 len values = B16V $ V.generate len (fromInteger . (values !!))

226+ mkVec IT32 len values = B32V $ V.generate len (fromInteger . (values !!))

227+ mkVec IT64 len values = B64V $ V.generate len (fromInteger . (values !!))

228+

210intTyName :: IntTy -> String

229intTyName :: IntTy -> String

211intTyName ITNative = "Int"

230intTyName ITNative = "Int"

212intTyName ITBig = "BigInt"

231intTyName ITBig = "BigInt"

213−intTyName sized = "B" ++ show (intTyWidth sized)

232+intTyName (ITFixed sized) = "B" ++ show (nativeTyWidth sized)

233+intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show count

214

234

215iCmp, iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim

235iCmp, iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim

236+iCmp ity op impl irop totality

216−iCmp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty (replicate 2 $ intTyToConst ity) IType) 2 impl (2, irop ity) totality

237+ = Prim (UN $ "prim__" ++ op ++ intTyName ity)

217−iBinOp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty (replicate 2 $ intTyToConst ity) (intTyToConst ity)) 2 impl (2, irop ity) totality

238+ (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt ITNative)))

218−iUnOp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty [intTyToConst ity] (intTyToConst ity)) 1 impl (1, irop ity) totality

239+ 2 impl (2, irop ity) totality

240+iBinOp ity op impl irop totality

241+ = Prim (UN $ "prim__" ++ op ++ intTyName ity)

242+ (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))

243+ 2 impl (2, irop ity) totality

244+iUnOp ity op impl irop totality

245+ = Prim (UN $ "prim__" ++ op ++ intTyName ity)

246+ (ty [AType . ATInt $ ity] (AType . ATInt $ ity))

247+ 1 impl (1, irop ity) totality

219

248

220iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim

249iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim

221iCoerce from to op impl irop =

250iCoerce from to op impl irop =

222 Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

251 Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

223− (ty [intTyToConst from] (intTyToConst to)) 1 (impl from to) (1, irop from to) total

252+ (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total

224

253

225iUn :: (Int -> Int) -> [Const] -> Maybe Const

254iUn :: (Int -> Int) -> [Const] -> Maybe Const

226iUn op [I x] = Just $ I (op x)

255iUn op [I x] = Just $ I (op x)

@@ -269,81 +298,81 @@ sBin op [Str x, Str y] = Just $ Str (op x y)

269sBin _ _ = Nothing

298sBin _ _ = Nothing

270

299

271bsrem :: IntTy -> [Const] -> Maybe Const

300bsrem :: IntTy -> [Const] -> Maybe Const

272−bsrem IT8 [B8 x, B8 y]

301+bsrem (ITFixed IT8) [B8 x, B8 y]

273 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))

302 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))

274−bsrem IT16 [B16 x, B16 y]

303+bsrem (ITFixed IT16) [B16 x, B16 y]

275 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))

304 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))

276−bsrem IT32 [B32 x, B32 y]

305+bsrem (ITFixed IT32) [B32 x, B32 y]

277 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))

306 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))

278−bsrem IT64 [B64 x, B64 y]

307+bsrem (ITFixed IT64) [B64 x, B64 y]

279 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))

308 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))

280bsrem ITNative [I x, I y] = Just $ I (x `rem` y)

309bsrem ITNative [I x, I y] = Just $ I (x `rem` y)

281bsrem _ _ = Nothing

310bsrem _ _ = Nothing

282

311

283bsdiv :: IntTy -> [Const] -> Maybe Const

312bsdiv :: IntTy -> [Const] -> Maybe Const

284−bsdiv IT8 [B8 x, B8 y]

313+bsdiv (ITFixed IT8) [B8 x, B8 y]

285 = Just $ B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8))

314 = Just $ B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8))

286−bsdiv IT16 [B16 x, B16 y]

315+bsdiv (ITFixed IT16) [B16 x, B16 y]

287 = Just $ B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16))

316 = Just $ B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16))

288−bsdiv IT32 [B32 x, B32 y]

317+bsdiv (ITFixed IT32) [B32 x, B32 y]

289 = Just $ B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32))

318 = Just $ B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32))

290−bsdiv IT64 [B64 x, B64 y]

319+bsdiv (ITFixed IT64) [B64 x, B64 y]

291 = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64))

320 = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64))

292bsdiv ITNative [I x, I y] = Just $ I (x `div` y)

321bsdiv ITNative [I x, I y] = Just $ I (x `div` y)

293bsdiv _ _ = Nothing

322bsdiv _ _ = Nothing

294

323

295bashr :: IntTy -> [Const] -> Maybe Const

324bashr :: IntTy -> [Const] -> Maybe Const

296−bashr IT8 [B8 x, B8 y]

325+bashr (ITFixed IT8) [B8 x, B8 y]

297 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))

326 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))

298−bashr IT16 [B16 x, B16 y]

327+bashr (ITFixed IT16) [B16 x, B16 y]

299 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))

328 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))

300−bashr IT32 [B32 x, B32 y]

329+bashr (ITFixed IT32) [B32 x, B32 y]

301 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))

330 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))

302−bashr IT64 [B64 x, B64 y]

331+bashr (ITFixed IT64) [B64 x, B64 y]

303 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))

332 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))

304bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)

333bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)

305bashr _ _ = Nothing

334bashr _ _ = Nothing

306

335

307bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const

336bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const

308−bUn IT8 op [B8 x] = Just $ B8 (op x)

337+bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x)

309−bUn IT16 op [B16 x] = Just $ B16 (op x)

338+bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x)

310−bUn IT32 op [B32 x] = Just $ B32 (op x)

339+bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x)

311−bUn IT64 op [B64 x] = Just $ B64 (op x)

340+bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x)

312bUn ITBig op [BI x] = Just $ BI (op x)

341bUn ITBig op [BI x] = Just $ BI (op x)

313bUn ITNative op [I x] = Just $ I (op x)

342bUn ITNative op [I x] = Just $ I (op x)

314bUn _ _ _ = Nothing

343bUn _ _ _ = Nothing

315

344

316bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const

345bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const

317−bitBin IT8 op [B8 x, B8 y] = Just $ B8 (op x y)

346+bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y)

318−bitBin IT16 op [B16 x, B16 y] = Just $ B16 (op x y)

347+bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y)

319−bitBin IT32 op [B32 x, B32 y] = Just $ B32 (op x y)

348+bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y)

320−bitBin IT64 op [B64 x, B64 y] = Just $ B64 (op x y)

349+bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y)

321bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)

350bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)

322bitBin ITNative op [I x, I y] = Just $ I (op x y)

351bitBin ITNative op [I x, I y] = Just $ I (op x y)

323bitBin _ _ _ = Nothing

352bitBin _ _ _ = Nothing

324

353

325bCmp :: IntTy -> (forall a. Ord a => a -> a -> Bool) -> [Const] -> Maybe Const

354bCmp :: IntTy -> (forall a. Ord a => a -> a -> Bool) -> [Const] -> Maybe Const

326−bCmp IT8 op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)

355+bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)

327−bCmp IT16 op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)

356+bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)

328−bCmp IT32 op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)

357+bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)

329−bCmp IT64 op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)

358+bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)

330bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)

359bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)

331bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)

360bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)

332bCmp _ _ _ = Nothing

361bCmp _ _ _ = Nothing

333

362

334toInt :: Integral a => IntTy -> a -> Const

363toInt :: Integral a => IntTy -> a -> Const

335−toInt IT8 x = B8 (fromIntegral x)

364+toInt (ITFixed IT8) x = B8 (fromIntegral x)

336−toInt IT16 x = B16 (fromIntegral x)

365+toInt (ITFixed IT16) x = B16 (fromIntegral x)

337−toInt IT32 x = B32 (fromIntegral x)

366+toInt (ITFixed IT32) x = B32 (fromIntegral x)

338−toInt IT64 x = B64 (fromIntegral x)

367+toInt (ITFixed IT64) x = B64 (fromIntegral x)

339toInt ITBig x = BI (fromIntegral x)

368toInt ITBig x = BI (fromIntegral x)

340toInt ITNative x = I (fromIntegral x)

369toInt ITNative x = I (fromIntegral x)

341

370

342intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const

371intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const

343−intToInt IT8 out [B8 x] = Just $ toInt out x

372+intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x

344−intToInt IT16 out [B16 x] = Just $ toInt out x

373+intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x

345−intToInt IT32 out [B32 x] = Just $ toInt out x

374+intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x

346−intToInt IT64 out [B64 x] = Just $ toInt out x

375+intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x

347intToInt ITBig out [BI x] = Just $ toInt out x

376intToInt ITBig out [BI x] = Just $ toInt out x

348intToInt ITNative out [I x] = Just $ toInt out x

377intToInt ITNative out [I x] = Just $ toInt out x

349intToInt _ _ _ = Nothing

378intToInt _ _ _ = Nothing

@@ -356,10 +385,10 @@ zext from to val

356zext _ _ _ = Nothing

385zext _ _ _ = Nothing

357

386

358sext :: IntTy -> IntTy -> [Const] -> Maybe Const

387sext :: IntTy -> IntTy -> [Const] -> Maybe Const

359−sext IT8 out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)

388+sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)

360−sext IT16 out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)

389+sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)

361−sext IT32 out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)

390+sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)

362−sext IT64 out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)

391+sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)

363sext ITBig _ _ = Nothing

392sext ITBig _ _ = Nothing

364sext from to val = intToInt from to val

393sext from to val = intToInt from to val

365

394

@@ -369,19 +398,19 @@ trunc _ ITBig _ = Nothing

369trunc from to val | intTyWidth from > intTyWidth to = intToInt from to val

398trunc from to val | intTyWidth from > intTyWidth to = intToInt from to val

370trunc _ _ _ = Nothing

399trunc _ _ _ = Nothing

371

400

372−getInt :: [Const] -> Maybe Integer

373−getInt [B8 x] = Just . toInteger $ x

374−getInt [B16 x] = Just . toInteger $ x

375−getInt [B32 x] = Just . toInteger $ x

376−getInt [B64 x] = Just . toInteger $ x

377−getInt [I x] = Just . toInteger $ x

378−getInt [BI x] = Just x

379−getInt _ = Nothing

380−

381intToStr :: [Const] -> Maybe Const

401intToStr :: [Const] -> Maybe Const

382−intToStr val | Just i <- getInt val = Just $ Str (show i)

402+intToStr val | [i] <- getInt val = Just $ Str (show i)

383intToStr _ = Nothing

403intToStr _ = Nothing

384

404

405+getInt :: [Const] -> [Integer]

406+getInt (B8 x : xs) = toInteger x : getInt xs

407+getInt (B16 x : xs) = toInteger x : getInt xs

408+getInt (B32 x : xs) = toInteger x : getInt xs

409+getInt (B64 x : xs) = toInteger x : getInt xs

410+getInt (I x : xs) = toInteger x : getInt xs

411+getInt (BI x : xs) = x : getInt xs

412+getInt _ = []

413+

385strToInt :: IntTy -> [Const] -> Maybe Const

414strToInt :: IntTy -> [Const] -> Maybe Const

386strToInt ity [Str x] = case reads x of

415strToInt ity [Str x] = case reads x of

387 [(n,"")] -> Just $ toInt ity (n :: Integer)

416 [(n,"")] -> Just $ toInt ity (n :: Integer)

@@ -389,7 +418,7 @@ strToInt ity [Str x] = case reads x of

389strToInt _ _ = Nothing

418strToInt _ _ = Nothing

390

419

391intToFloat :: [Const] -> Maybe Const

420intToFloat :: [Const] -> Maybe Const

392−intToFloat val | Just i <- getInt val = Just $ Fl (fromIntegral i)

421+intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i)

393intToFloat _ = Nothing

422intToFloat _ = Nothing

394

423

395floatToInt :: IntTy -> [Const] -> Maybe Const

424floatToInt :: IntTy -> [Const] -> Maybe Const