diff --git a/examples/NanoFeldspar/Core.hs b/examples/NanoFeldspar/Core.hs
--- a/examples/NanoFeldspar/Core.hs
+++ b/examples/NanoFeldspar/Core.hs
@@ -165,23 +165,23 @@
 
 -- | Show the expression
 showExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String
-showExpr = render . reifySmart canShareDict
+showExpr = render . reifySmart (const True) canShareDict
 
 -- | Print the expression
 printExpr :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()
-printExpr = Syntactic.printExpr . reifySmart canShareDict
+printExpr = Syntactic.printExpr . reifySmart (const True) canShareDict
 
 -- | Draw the syntax tree using ASCII
 showAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> String
-showAST = Syntactic.showAST . reifySmart canShareDict
+showAST = Syntactic.showAST . reifySmart (const True) canShareDict
 
 -- | Draw the syntax tree on the terminal using ASCII
 drawAST :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> IO ()
-drawAST = Syntactic.drawAST . reifySmart canShareDict
+drawAST = Syntactic.drawAST . reifySmart (const True) canShareDict
 
 -- | Evaluation
 eval :: (Syntactic a, Domain a ~ FeldDomainAll) => a -> Internal a
-eval = evalBind . reifySmart canShareDict
+eval = evalBind . reifySmart (const True) canShareDict
 
 
 
diff --git a/examples/NanoFeldspar/Extra.hs b/examples/NanoFeldspar/Extra.hs
--- a/examples/NanoFeldspar/Extra.hs
+++ b/examples/NanoFeldspar/Extra.hs
@@ -82,7 +82,7 @@
 reifySimp :: (Syntactic a, Domain a ~ FeldDomainAll) =>
     a -> ASTF ((FODomain (Let :+: (FeldDomain :|| Eq :| Show))) Typeable Top) (Internal a)
 reifySimp = flip evalState 0 .
-    (   codeMotion prjDictFO canShareDict
+    (   codeMotion (const True) prjDictFO canShareDict
     .   optimize constFold
     <=< reifyM
     .   desugar
diff --git a/src/Language/Syntactic/Sharing/SimpleCodeMotion.hs b/src/Language/Syntactic/Sharing/SimpleCodeMotion.hs
--- a/src/Language/Syntactic/Sharing/SimpleCodeMotion.hs
+++ b/src/Language/Syntactic/Sharing/SimpleCodeMotion.hs
@@ -120,11 +120,12 @@
 -- | Choose a sub-expression to share
 choose :: forall dom a
     .  AlphaEq dom dom dom [(VarId,VarId)]
-    => PrjDict dom
+    => (forall c. ASTF dom c -> Bool)
+    -> PrjDict dom
     -> MkInjDict dom
     -> ASTF dom a
     -> Maybe (Chosen dom a)
-choose pd mkId a = chooseEnv initEnv a
+choose hoistOver pd mkId a = chooseEnv initEnv a
   where
     initEnv = Env
         { inLambda     = False
@@ -137,7 +138,9 @@
         | liftable pd env b
         , Just id <- mkId b a
         = Just $ Chosen id b
-    chooseEnv env b = chooseEnvSub env b
+    chooseEnv env b
+        | hoistOver b = chooseEnvSub env b
+        | otherwise       = Nothing
 
     -- | Like 'chooseEnv', but does not consider the top expression for sharing
     chooseEnvSub :: Env dom -> AST dom b -> Maybe (Chosen dom a)
@@ -159,27 +162,28 @@
     .  ( ConstrainedBy dom Typeable
        , AlphaEq dom dom dom [(VarId,VarId)]
        )
-    => PrjDict dom
+    => (forall c. ASTF dom c -> Bool)  -- ^ Control wether a sub-expression can be hoisted over the given expression
+    -> PrjDict dom
     -> MkInjDict dom
     -> ASTF dom a
     -> State VarId (ASTF dom a)
-codeMotion pd mkId a
-    | Just (Chosen id b) <- choose pd mkId a = share id b
+codeMotion hoistOver pd mkId a
+    | Just (Chosen id b) <- choose hoistOver pd mkId a = share id b
     | otherwise = descend a
   where
     share :: InjDict dom b a -> ASTF dom b -> State VarId (ASTF dom a)
     share id b = do
-        b' <- codeMotion pd mkId b
+        b' <- codeMotion hoistOver pd mkId b
         v  <- get; put (v+1)
         let x = Sym (injVariable id v)
-        body <- codeMotion pd mkId $ substitute b x a
+        body <- codeMotion hoistOver pd mkId $ substitute b x a
         return
             $  Sym (injLet id)
             :$ b'
             :$ (Sym (injLambda id v) :$ body)
 
     descend :: AST dom b -> State VarId (AST dom b)
-    descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion pd mkId a)
+    descend (f :$ a) = liftM2 (:$) (descend f) (codeMotion hoistOver pd mkId a)
     descend a        = return a
 
 
@@ -198,10 +202,11 @@
        , Domain a ~ HODomain dom p pVar
        , p :< Typeable
        )
-    => MkInjDict (FODomain dom p pVar)
+    => (forall c. ASTF (FODomain dom p pVar) c -> Bool)
+    -> MkInjDict (FODomain dom p pVar)
     -> a
     -> ASTF (FODomain dom p pVar) (Internal a)
-reifySmart mkId = flip evalState 0 . (codeMotion prjDictFO mkId <=< reifyM . desugar)
+reifySmart hoistOver mkId = flip evalState 0 . (codeMotion hoistOver prjDictFO mkId <=< reifyM . desugar)
 
 
 
diff --git a/syntactic.cabal b/syntactic.cabal
--- a/syntactic.cabal
+++ b/syntactic.cabal
@@ -1,5 +1,5 @@
 Name:           syntactic
-Version:        1.7.1
+Version:        1.8
 Synopsis:       Generic abstract syntax, and utilities for embedded languages
 Description:    This library provides:
                 .
@@ -174,8 +174,6 @@
   hs-source-dirs: tests examples
 
   main-is: NanoFeldsparTree.hs
-
-  other-modules:
 
   default-language: Haskell2010