basis/tools/deploy/backend/backend.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces make continuations.private kernel.private init
   4 assocs kernel vocabs words sequences memory io system arrays
   5 continuations math definitions mirrors splitting parser classes
   6 summary layouts vocabs.loader prettyprint.config prettyprint debugger
   7 io.streams.c io.files io.files.temp io.pathnames io.directories
   8 io.directories.hierarchy io.backend quotations io.launcher
   9 tools.deploy.config tools.deploy.config.editor bootstrap.image
  10 io.encodings.utf8 destructors accessors hashtables
  11 vocabs.metadata.resources ;
  12 IN: tools.deploy.backend
  13
  14 : copy-vm ( executable bundle-name -- vm )
  15     prepend-path vm over copy-file ;
  16
  17 : copy-resources ( manifest name dir -- )
  18     append-path swap [ copy-vocab-resources ] with each ;
  19
  20 : image-name ( vocab bundle-name -- str )
  21     prepend-path ".image" append ;
  22
  23 : copy-lines ( -- )
  24     readln [ print flush copy-lines ] when* ;
  25
  26 : run-with-output ( arguments -- )
  27     <process>
  28         swap >>command
  29         +stdout+ >>stderr
  30         +closed+ >>stdin
  31         +low-priority+ >>priority
  32     utf8 [ copy-lines ] with-process-reader ;
  33
  34 : make-boot-image ( -- )
  35     #! If stage1 image doesn't exist, create one.
  36     my-boot-image-name resource-path exists?
  37     [ my-arch make-image ] unless ;
  38
  39 : bootstrap-profile ( -- profile )
  40     [
  41         deploy-math? get [ "math" , ] when
  42         deploy-threads? get [ "threads" , ] when
  43         "compiler" ,
  44         deploy-ui? get [ "ui" , ] when
  45         deploy-unicode? get [ "unicode" , ] when
  46         native-io? [ "io" , ] when
  47     ] { } make ;
  48
  49 : staging-image-name ( profile -- name )
  50     "-" join "staging." ".image" surround temp-file ;
  51
  52 DEFER: ?make-staging-image
  53
  54 : staging-command-line ( profile -- flags )
  55     [
  56         "-staging" ,
  57         dup empty? [
  58             "-i=" my-boot-image-name append ,
  59         ] [
  60             dup but-last ?make-staging-image
  61             "-resource-path=" "" resource-path append ,
  62             "-i=" over but-last staging-image-name append ,
  63             "-run=tools.deploy.restage" ,
  64         ] if
  65         "-output-image=" over staging-image-name append ,
  66         "-include=" swap " " join append ,
  67         "-no-user-init" ,
  68         "-pic=0" ,
  69     ] { } make ;
  70
  71 : run-factor ( vm flags -- )
  72     swap prefix dup . run-with-output ; inline
  73
  74 : make-staging-image ( profile -- )
  75     vm swap staging-command-line run-factor ;
  76
  77 : ?make-staging-image ( profile -- )
  78     dup staging-image-name exists?
  79     [ drop ] [ make-staging-image ] if ;
  80
  81 : make-deploy-config ( vocab -- file )
  82     [ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ]
  83     [ "deploy-config-" prepend temp-file ] bi
  84     [ utf8 set-file-contents ] keep ;
  85
  86 : deploy-command-line ( image vocab manifest-file config -- flags )
  87     [
  88         bootstrap-profile ?make-staging-image
  89
  90         [
  91             "-i=" bootstrap-profile staging-image-name append ,
  92             "-resource-path=" "" resource-path append ,
  93             "-run=tools.deploy.shaker" ,
  94             "-vocab-manifest-out=" prepend ,
  95             [ "-deploy-vocab=" prepend , ]
  96             [ make-deploy-config "-deploy-config=" prepend , ] bi
  97             "-output-image=" prepend ,
  98             "-pic=0" ,
  99         ] { } make
 100     ] bind ;
 101
 102 : make-deploy-image ( vm image vocab config -- manifest )
 103     make-boot-image
 104     over "vocab-manifest-" prepend temp-file
 105     [ swap deploy-command-line run-factor ]
 106     [ utf8 file-lines ] bi ;
 107
 108 HOOK: deploy* os ( vocab -- )