import qualified Maybe
import qualified System.IO.Unsafe
import qualified Data.Map as Map
+import qualified Data.Accessor.Monad.Trans.State as MonadState
-- GHC API
import qualified GHC
tfp_to_int :: Type.Type -> TypeSession Int
tfp_to_int ty = do
hscenv <- MonadState.get tsHscEnv
- let norm_ty = normalise_tfp_int hscenv ty
+ let norm_ty = normalize_tfp_int hscenv ty
case Type.splitTyConApp_maybe norm_ty of
Just (tycon, args) -> do
let name = Name.getOccString (TyCon.tyConName tycon)
tfp_to_int' ty = do
lens <- MonadState.get tsTfpInts
hscenv <- MonadState.get tsHscEnv
- let norm_ty = normalise_tfp_int hscenv ty
+ let norm_ty = normalize_tfp_int hscenv ty
let existing_len = Map.lookup (OrdType norm_ty) lens
case existing_len of
Just len -> return len
libdir = DynFlags.topDir dynflags
dynflags = HscTypes.hsc_dflags env
-normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
-normalise_tfp_int env ty =
+normalize_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
+normalize_tfp_int env ty =
System.IO.Unsafe.unsafePerformIO $
- normaliseType env ty
+ normalizeType env ty
--- | Get the width of a SizedWord type
--- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
--- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)
-
sized_word_len_ty :: Type.Type -> Type.Type
sized_word_len_ty ty = len
where
Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
[len] = args
--- | Get the width of a SizedInt type
--- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
--- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)
-
sized_int_len_ty :: Type.Type -> Type.Type
sized_int_len_ty ty = len
where
Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
[len] = args
--- | Get the upperbound of a RangedWord type
--- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
--- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)
-
ranged_word_bound_ty :: Type.Type -> Type.Type
ranged_word_bound_ty ty = len
where
Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
[len] = args
--- | Evaluate a core Type representing type level int from the TypeLevel
--- library to a real int.
--- eval_type_level_int :: Type.Type -> Int
--- eval_type_level_int ty =
--- unsafeRunGhc $ do
--- -- Automatically import modules for any fully qualified identifiers
--- setDynFlag DynFlags.Opt_ImplicitImportQualified
---
--- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
--- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
--- let undef = hsTypedUndef $ coreToHsType ty
--- let app = HsExpr.HsApp (to_int) (undef)
---
--- core <- toCore [] app
--- execCore core
-
--- | Get the length of a FSVec type
--- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
--- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)
-
tfvec_len_ty :: Type.Type -> Type.Type
tfvec_len_ty ty = len
where
-- arguments, to get at the value arguments.
n = length tyvars + length predtypes
-getLiterals :: HscTypes.HscEnv -> CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
-getLiterals _ app@(CoreSyn.App _ _) = literals
- where
- (CoreSyn.Var f, args) = CoreSyn.collectArgs app
- literals = filter (is_lit) args
-
-getLiterals _ lit@(CoreSyn.Lit _) = [lit]
-
-getLiterals hscenv letrec@(CoreSyn.Let (CoreSyn.NonRec letBind (letExpr)) letRes) = [lit]
- where
- ty = Var.varType letBind
- litInt = eval_tfp_int hscenv ty
- lit = CoreSyn.Lit (Literal.mkMachInt (toInteger litInt))
-
-getLiterals _ expr = error $ "\nCoreTools.getLiterals: Not a known Lit: " ++ pprString expr
+-- Finds out what literal Integer this expression represents.
+getIntegerLiteral :: CoreSyn.CoreExpr -> TranslatorSession Integer
+getIntegerLiteral expr =
+ case CoreSyn.collectArgs expr of
+ (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt integer)])
+ | getFullString f == "GHC.Integer.smallInteger" -> return integer
+ (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt64 integer)])
+ | getFullString f == "GHC.Integer.int64ToInteger" -> return integer
+ (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord integer)])
+ | getFullString f == "GHC.Integer.wordToInteger" -> return integer
+ (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord64 integer)])
+ | getFullString f == "GHC.Integer.word64ToInteger" -> return integer
+ -- fromIntegerT returns the integer corresponding to the type of its
+ -- (third) argument. Since it is polymorphic, the type of that
+ -- argument is passed as the first argument, so we can just use that
+ -- one.
+ (CoreSyn.Var f, [CoreSyn.Type dec_ty, dec_dict, CoreSyn.Type num_ty, num_dict, arg])
+ | getFullString f == "Types.Data.Num.Ops.fromIntegerT" -> do
+ int <- MonadState.lift tsType $ tfp_to_int dec_ty
+ return $ toInteger int
+ _ -> error $ "CoreTools.getIntegerLiteral: Unsupported Integer literal: " ++ pprString expr
reduceCoreListToHsList ::
[HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden
let binders = take i wildbndrs ++ [sel_bndr] ++ drop (i+1) wildbndrs
return $ CoreSyn.Case scrut scrut_bndr scrut_ty [(CoreSyn.DataAlt datacon, binders, CoreSyn.Var sel_bndr)]
dcs -> error $ "CoreTools.mkSelCase: Scrutinee type must have exactly one datacon. Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "' Datacons: " ++ (show dcs) ++ " Type: " ++ (pprString scrut_ty)
- Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no tycon? Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "'"
+ Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no tycon? Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "'" ++ " Type: " ++ (pprString scrut_ty)
projects / matthijs / master-project / cλash.git / blobdiff