src/Gyehoek/CPS/Close.hs

@@ -40,11 +40,10 @@ close = transformM \case
         ( f_code_l
         , ab & absBody %~ bindEnv f_code_l (boundNames ++ frees)
         )
-    let labels = MkLabel <$> boundNames
     pure [cps|
       (letrec #{bs'}
         (letrec ((#{e_l} (κ #{boundNames} #{e})))
-          (prim (make-shared-closure #{labels} #{frees})
+          (prim (make-shared-closure #{boundNames} #{frees})
             #{e_l})))
     |]
 

src/Gyehoek/CPS/Stackify.hs

@@ -212,44 +212,69 @@ blah = [cps|
 
 p :: HoistedProgram
 p = [cps|
-(letrec ((make-closure-cont22 (κ (prim-k7) (prim (- n 1) prim-k7)))
+(letrec ((r12-code32 (κ (r12 start-ktail0 x13) (continue start-ktail0 x13)))
-         (env-cont18
+         (prim-k7-code22
-          (κ (n lambda-tail1)
+          (κ (prim-k7 fac r6 r8 n x9 prim-k11 lambda-tail1 r10)
             (prim
-             (make-closure $prim-k11-code14 lambda-tail1)
+             (make-shared-closure (r8) (n x9 prim-k11 lambda-tail1 r10))
-             make-closure-cont16)))
+             letrec-body-cont18)))
-         (env-cont15 (κ (lambda-tail1) (continue lambda-tail1 r10)))
+         (letrec-body-cont24
-         (falsey-cont5
+          (κ (truthy-cont4 falsey-cont5)
-          (κ ()
+            (if r2
+              truthy-cont4
+              falsey-cont5)))
+         (letrec-body-cont18 (κ (r8) (fac r6 r8)))
+         (prim-k11-code16
+          (κ (prim-k11 lambda-tail1 r10)
+            (continue lambda-tail1 r10)))
+         (falsey-cont5-code26
+          (κ (truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7
+              fac r6 r8 x9 prim-k11 r10)
             (prim
-             (make-closure $prim-k7-code20 fac n lambda-tail1)
+             (make-shared-closure
-             make-closure-cont22)))
+              (prim-k7)
-         (truthy-cont4 (κ () (continue lambda-tail1 1)))
+              (fac r6 r8 n x9 prim-k11 lambda-tail1 r10))
-         (r12-code26 (κ (x13) (prim (get-env) env-cont27)))
+             letrec-body-cont21)))
-         (make-closure-cont28 (κ (r12) (fac 20 r12)))
+         (letrec-body-cont31 (κ (r12) (fac 20 r12)))
-         (make-closure-cont16 (κ (prim-k11) (prim (* n x9) prim-k11)))
+         (r8-code19
-         (env-cont30
+          (κ (r8 n x9 prim-k11 lambda-tail1 r10)
-          (κ ()
             (prim
-             (make-closure $prim-k3-code23 lambda-tail1 n fac)
+             (make-shared-closure (prim-k11) (lambda-tail1 r10))
-             make-closure-cont25)))
+             letrec-body-cont15)))
-         (env-cont21
+         (letrec-body-cont28 (κ (prim-k3) (prim (zero? n) prim-k3)))
-          (κ (fac n lambda-tail1)
+         (truthy-cont4-code25
+          (κ (truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7 fac
+              r6 r8 x9 prim-k11 r10)
+            (continue lambda-tail1 1)))
+         (fac-code35
+          (κ (fac n prim-k3 r2 truthy-cont4 falsey-cont5 lambda-tail1
+              prim-k7 r6 r8 x9 prim-k11 r10)
             (prim
-             (make-closure $r8-code17 n lambda-tail1)
+             (make-shared-closure
-             make-closure-cont19)))
+              (prim-k3)
-         (make-closure-cont19 (κ (r8) (fac r6 r8)))
+              (r2 truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7
-         (prim-k7-code20 (κ (r6) (prim (get-env) env-cont21)))
+               fac r6 r8 x9 prim-k11 r10))
-         (prim-k11-code14 (κ (r10) (prim (get-env) env-cont15)))
+             letrec-body-cont28)))
-         (make-closure-cont25 (κ (prim-k3) (prim (zero? n) prim-k3)))
+         (prim-k3-code29
-         (make-closure-cont31
+          (κ (prim-k3 r2 truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7
+              fac r6 r8 x9 prim-k11 r10)
+            (prim
+             (make-shared-closure
+              (truthy-cont4 falsey-cont5)
+              (lambda-tail1 n prim-k7 fac r6 r8 x9 prim-k11 r10))
+             letrec-body-cont24)))
+         (letrec-body-cont21 (κ (prim-k7) (prim (- n 1) prim-k7)))
+         (letrec-body-cont15 (κ (prim-k11) (prim (* n x9) prim-k11)))
+         (letrec-body-cont34
           (κ (fac)
-            (prim (make-closure $r12-code26 start-ktail0) make-closure-cont28)))
+            (prim
-         (prim-k3-code23 (κ (r2) (prim (get-env) env-cont24)))
+             (make-shared-closure (r12) (start-ktail0 x13))
-         (env-cont27 (κ (start-ktail0) (continue start-ktail0 x13)))
+             letrec-body-cont31))))
-         (r8-code17 (κ (x9) (prim (get-env) env-cont18)))
-         (env-cont24 (κ (lambda-tail1 n fac) (if r2 truthy-cont4 falsey-cont5)))
-         (fac-code29 (λ (n lambda-tail1) (prim (get-env) env-cont30))))
   (λ (start-ktail0)
-    (prim (make-closure $fac-code29) make-closure-cont31)))
+    (prim
+     (make-shared-closure
+      (fac)
+      (n prim-k3 r2 truthy-cont4 falsey-cont5 lambda-tail1
+       prim-k7 r6 r8 x9 prim-k11 r10))
+     letrec-body-cont34)))
 |]