-- arguments without any free tyvars, since tyvars those wouldn't be in scope
-- in the new function.
typeprop expr@(App (Var f) arg@(Type ty)) | not $ has_free_tyvars arg = do
- id <- cloneVar f
- let newty = Type.applyTy (Id.idType f) ty
- let newf = Var.setVarType id newty
body_maybe <- Trans.lift $ getGlobalBind f
case body_maybe of
Just body -> do
let newbody = App body (Type ty)
- Trans.lift $ addGlobalBind newf newbody
+ -- Create a new function with the same name but a new body
+ newf <- mkFunction f newbody
+ -- Replace the application with this new function
change (Var newf)
-- If we don't have a body for the function called, leave it unchanged (it
-- should be a primitive function then).
-- Create a new body that consists of a lambda for all new arguments and
-- the old body applied to some arguments.
let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs)
- -- Create a new function name
- id <- cloneVar f
- let newf = Var.setVarType id (CoreUtils.exprType newbody)
- -- Add the new function
- Trans.lift $ addGlobalBind newf newbody
+ -- Create a new function with the same name but a new body
+ newf <- mkFunction f newbody
-- Replace the original application with one of the new function to the
-- new arguments.
change $ MkCore.mkCoreApps (Var newf) newargs
return $ filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings
normalizeBind :: CoreBndr -> TransformSession ()
-normalizeBind bndr = do
- normalized_funcs <- getA tsNormalized
- -- See if this function was normalized already
- if VarSet.elemVarSet bndr normalized_funcs
+normalizeBind bndr =
+ -- Skip binders that have a polymorphic type, since it's impossible to
+ -- create polymorphic hardware.
+ if is_poly (Var bndr)
then
- -- Yup, don't do it again
- return ()
+ -- This should really only happen at the top level... TODO: Give
+ -- a different error if this happens down in the recursion.
+ error $ "Function " ++ show bndr ++ " is polymorphic, can't normalize"
else do
- -- Nope, note that it has been and do it.
- modA tsNormalized (flip VarSet.extendVarSet bndr)
- expr_maybe <- getGlobalBind bndr
- case expr_maybe of
- Just expr -> do
- -- Normalize this expression
- trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr ) ++ "\n") $ return ()
- expr' <- dotransforms transforms expr
- trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
- -- And store the normalized version in the session
- modA tsBindings (Map.insert bndr expr')
- -- Find all vars used with a function type. All of these should be global
- -- binders (i.e., functions used), since any local binders with a function
- -- type should have been inlined already.
- let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isFunTy . snd . Type.splitForAllTys . Id.idType) v) expr'
- let used_funcs = VarSet.varSetElems used_funcs_set
- -- Process each of the used functions recursively
- mapM normalizeBind used_funcs
+ normalized_funcs <- getA tsNormalized
+ -- See if this function was normalized already
+ if VarSet.elemVarSet bndr normalized_funcs
+ then
+ -- Yup, don't do it again
return ()
- -- We don't have a value for this binder, let's assume this is a builtin
- -- function. This might need some extra checking and a nice error
- -- message).
- Nothing -> return ()
+ else do
+ -- Nope, note that it has been and do it.
+ modA tsNormalized (flip VarSet.extendVarSet bndr)
+ expr_maybe <- getGlobalBind bndr
+ case expr_maybe of
+ Just expr -> do
+ -- Introduce an empty Let at the top level, so there will always be
+ -- a let in the expression (none of the transformations will remove
+ -- the last let).
+ let expr' = Let (Rec []) expr
+ -- Normalize this expression
+ trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
+ expr' <- dotransforms transforms expr'
+ trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
+ -- And store the normalized version in the session
+ modA tsBindings (Map.insert bndr expr')
+ -- Find all vars used with a function type. All of these should be global
+ -- binders (i.e., functions used), since any local binders with a function
+ -- type should have been inlined already.
+ let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isFunTy . snd . Type.splitForAllTys . Id.idType) v) expr'
+ let used_funcs = VarSet.varSetElems used_funcs_set
+ -- Process each of the used functions recursively
+ mapM normalizeBind used_funcs
+ return ()
+ -- We don't have a value for this binder, let's assume this is a builtin
+ -- function. This might need some extra checking and a nice error
+ -- message).
+ Nothing -> return ()
projects / matthijs / master-project / cλash.git / blobdiff