import HsValueMap
import TranslatorTypes
import FlattenTypes
+import CoreTools
-- Extract the arguments from a data constructor application (that is, the
-- normal args, leaving out the type args).
-- | Flatten a haskell function
flattenFunction ::
HsFunction -- ^ The function to flatten
- -> CoreBind -- ^ The function value
+ -> (CoreBndr, CoreExpr) -- ^ The function value
-> FlatFunction -- ^ The resulting flat function
-flattenFunction _ (Rec _) = error "Recursive binders not supported"
-flattenFunction hsfunc bind@(NonRec var expr) =
+flattenFunction hsfunc (var, expr) =
FlatFunction args res defs sigs
where
init_state = ([], [], 0)
sig_id <- genSignalId SigInternal ty
-- Add a name hint to the signal
addNameHint (Name.getOccString id) sig_id
- addDef (UncondDef (Right $ Literal lit) sig_id)
+ addDef (UncondDef (Right $ Literal lit Nothing) sig_id)
return ([], Single sig_id)
+ IdInfo.VanillaGlobal ->
+ -- Treat references to globals as an application with zero elements
+ flattenApplicationExpr binds (CoreUtils.exprType var) id []
otherwise ->
error $ "Ids other than local vars and dataconstructors not supported: " ++ (showSDoc $ ppr id)
([], b) <- flattenExpr binds (last args)
res <- mkEqComparisons a b
return ([], res)
+ else if fname == "fromInteger" then do
+ let [to_ty, to_dict, val] = args
+ -- We assume this is an application of the GHC.Integer.smallInteger
+ -- function to a literal
+ let App smallint (Lit lit) = val
+ let (Literal.MachInt int) = lit
+ let ty = CoreUtils.exprType app
+ sig_id <- genSignalId SigInternal ty
+ -- TODO: fromInteger is defined for more types than just SizedWord
+ let len = sized_word_len ty
+ -- Use a to_unsigned to translate the number (a natural) to an unsiged
+ -- (array of bits)
+ let lit_str = "to_unsigned(" ++ (show int) ++ ", " ++ (show len) ++ ")"
+ -- Set the signal to our literal unconditionally, but add the type so
+ -- the literal will be typecast to the proper type.
+ addDef $ UncondDef (Right $ Literal lit_str (Just ty)) sig_id
+ return ([], Single sig_id)
else
flattenApplicationExpr binds (CoreUtils.exprType app) f args
where
-- TODO: Special casing for higher order functions
-- Flatten the scrutinee
(_, res) <- flattenExpr binds scrut
+ -- Put the scrutinee in the BindMap
+ let binds' = (b, Left res) : binds
case alts of
- -- TODO include b in the binds list
- [alt] -> flattenSingleAltCaseExpr binds res b alt
+ [alt] -> flattenSingleAltCaseExpr binds' res b alt
-- Reverse the alternatives, so the __DEFAULT alternative ends up last
- otherwise -> flattenMultipleAltCaseExpr binds res b (reverse alts)
+ otherwise -> flattenMultipleAltCaseExpr binds' res b (reverse alts)
where
flattenSingleAltCaseExpr ::
BindMap