diff --git a/src/Gyehoek/CPS/Close.hs b/src/Gyehoek/CPS/Close.hs index 856f57b..d715c2c 100644 --- a/src/Gyehoek/CPS/Close.hs +++ b/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}))) |] diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index fcf3e01..4896873 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/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))) - (env-cont18 - (κ (n lambda-tail1) +(letrec ((r12-code32 (κ (r12 start-ktail0 x13) (continue start-ktail0 x13))) + (prim-k7-code22 + (κ (prim-k7 fac r6 r8 n x9 prim-k11 lambda-tail1 r10) (prim - (make-closure $prim-k11-code14 lambda-tail1) - make-closure-cont16))) - (env-cont15 (κ (lambda-tail1) (continue lambda-tail1 r10))) - (falsey-cont5 - (κ () + (make-shared-closure (r8) (n x9 prim-k11 lambda-tail1 r10)) + letrec-body-cont18))) + (letrec-body-cont24 + (κ (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-closure-cont22))) - (truthy-cont4 (κ () (continue lambda-tail1 1))) - (r12-code26 (κ (x13) (prim (get-env) env-cont27))) - (make-closure-cont28 (κ (r12) (fac 20 r12))) - (make-closure-cont16 (κ (prim-k11) (prim (* n x9) prim-k11))) - (env-cont30 - (κ () + (make-shared-closure + (prim-k7) + (fac r6 r8 n x9 prim-k11 lambda-tail1 r10)) + letrec-body-cont21))) + (letrec-body-cont31 (κ (r12) (fac 20 r12))) + (r8-code19 + (κ (r8 n x9 prim-k11 lambda-tail1 r10) (prim - (make-closure $prim-k3-code23 lambda-tail1 n fac) - make-closure-cont25))) - (env-cont21 - (κ (fac n lambda-tail1) + (make-shared-closure (prim-k11) (lambda-tail1 r10)) + letrec-body-cont15))) + (letrec-body-cont28 (κ (prim-k3) (prim (zero? n) prim-k3))) + (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-closure-cont19))) - (make-closure-cont19 (κ (r8) (fac r6 r8))) - (prim-k7-code20 (κ (r6) (prim (get-env) env-cont21))) - (prim-k11-code14 (κ (r10) (prim (get-env) env-cont15))) - (make-closure-cont25 (κ (prim-k3) (prim (zero? n) prim-k3))) - (make-closure-cont31 + (make-shared-closure + (prim-k3) + (r2 truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7 + fac r6 r8 x9 prim-k11 r10)) + letrec-body-cont28))) + (prim-k3-code29 + (κ (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-k3-code23 (κ (r2) (prim (get-env) env-cont24))) - (env-cont27 (κ (start-ktail0) (continue start-ktail0 x13))) - (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)))) + (prim + (make-shared-closure (r12) (start-ktail0 x13)) + letrec-body-cont31)))) (λ (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))) |]